From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/testsuite/ada/acats/tests/a/a22006b.ada | 38 + gcc/testsuite/ada/acats/tests/a/a22006c.ada | 51 + gcc/testsuite/ada/acats/tests/a/a22006d.ada | 41 + gcc/testsuite/ada/acats/tests/a/a26007a.tst | 48 + gcc/testsuite/ada/acats/tests/a/a27003a.ada | 51 + gcc/testsuite/ada/acats/tests/a/a29003a.ada | 102 ++ gcc/testsuite/ada/acats/tests/a/a2a031a.ada | 72 ++ gcc/testsuite/ada/acats/tests/a/a33003a.ada | 49 + gcc/testsuite/ada/acats/tests/a/a34017c.ada | 105 +++ gcc/testsuite/ada/acats/tests/a/a35101b.ada | 50 + gcc/testsuite/ada/acats/tests/a/a35402a.ada | 63 ++ gcc/testsuite/ada/acats/tests/a/a35801f.ada | 64 ++ gcc/testsuite/ada/acats/tests/a/a35902c.ada | 51 + gcc/testsuite/ada/acats/tests/a/a38106d.ada | 99 ++ gcc/testsuite/ada/acats/tests/a/a38106e.ada | 99 ++ gcc/testsuite/ada/acats/tests/a/a49027a.ada | 85 ++ gcc/testsuite/ada/acats/tests/a/a49027b.ada | 159 ++++ gcc/testsuite/ada/acats/tests/a/a49027c.ada | 70 ++ gcc/testsuite/ada/acats/tests/a/a54b01a.ada | 119 +++ gcc/testsuite/ada/acats/tests/a/a54b02a.ada | 184 ++++ gcc/testsuite/ada/acats/tests/a/a55b12a.ada | 147 +++ gcc/testsuite/ada/acats/tests/a/a55b13a.ada | 128 +++ gcc/testsuite/ada/acats/tests/a/a55b14a.ada | 112 +++ gcc/testsuite/ada/acats/tests/a/a71004a.ada | 130 +++ gcc/testsuite/ada/acats/tests/a/a73001i.ada | 73 ++ gcc/testsuite/ada/acats/tests/a/a73001j.ada | 78 ++ gcc/testsuite/ada/acats/tests/a/a74105b.ada | 78 ++ gcc/testsuite/ada/acats/tests/a/a74106a.ada | 168 ++++ gcc/testsuite/ada/acats/tests/a/a74106b.ada | 159 ++++ gcc/testsuite/ada/acats/tests/a/a74106c.ada | 155 +++ gcc/testsuite/ada/acats/tests/a/a74205e.ada | 149 +++ gcc/testsuite/ada/acats/tests/a/a74205f.ada | 93 ++ gcc/testsuite/ada/acats/tests/a/a83009a.ada | 198 ++++ gcc/testsuite/ada/acats/tests/a/a83009b.ada | 196 ++++ gcc/testsuite/ada/acats/tests/a/a83a02a.ada | 120 +++ gcc/testsuite/ada/acats/tests/a/a83a02b.ada | 116 +++ gcc/testsuite/ada/acats/tests/a/a83a06a.ada | 94 ++ gcc/testsuite/ada/acats/tests/a/a83a08a.ada | 102 ++ gcc/testsuite/ada/acats/tests/a/a83c01c.ada | 83 ++ gcc/testsuite/ada/acats/tests/a/a83c01h.ada | 99 ++ gcc/testsuite/ada/acats/tests/a/a83c01i.ada | 112 +++ gcc/testsuite/ada/acats/tests/a/a85007d.ada | 156 +++ gcc/testsuite/ada/acats/tests/a/a85013b.ada | 89 ++ gcc/testsuite/ada/acats/tests/a/a87b59a.ada | 250 +++++ gcc/testsuite/ada/acats/tests/a/a95001c.ada | 74 ++ gcc/testsuite/ada/acats/tests/a/a95074d.ada | 82 ++ gcc/testsuite/ada/acats/tests/a/a97106a.ada | 86 ++ gcc/testsuite/ada/acats/tests/a/a99006a.ada | 66 ++ gcc/testsuite/ada/acats/tests/a/aa2010a.ada | 199 ++++ gcc/testsuite/ada/acats/tests/a/aa2012a.ada | 70 ++ gcc/testsuite/ada/acats/tests/a/ac1015b.ada | 81 ++ gcc/testsuite/ada/acats/tests/a/ac3106a.ada | 216 +++++ gcc/testsuite/ada/acats/tests/a/ac3206a.ada | 120 +++ gcc/testsuite/ada/acats/tests/a/ac3207a.ada | 92 ++ gcc/testsuite/ada/acats/tests/a/ad7001b.ada | 66 ++ gcc/testsuite/ada/acats/tests/a/ad7001c0.ada | 65 ++ gcc/testsuite/ada/acats/tests/a/ad7001c1.ada | 60 ++ gcc/testsuite/ada/acats/tests/a/ad7001d0.ada | 60 ++ gcc/testsuite/ada/acats/tests/a/ad7001d1.ada | 55 ++ gcc/testsuite/ada/acats/tests/a/ad7006a.ada | 47 + gcc/testsuite/ada/acats/tests/a/ad7101a.ada | 51 + gcc/testsuite/ada/acats/tests/a/ad7101c.ada | 50 + gcc/testsuite/ada/acats/tests/a/ad7102a.ada | 50 + gcc/testsuite/ada/acats/tests/a/ad7103a.ada | 50 + gcc/testsuite/ada/acats/tests/a/ad7103c.ada | 50 + gcc/testsuite/ada/acats/tests/a/ad7104a.ada | 50 + gcc/testsuite/ada/acats/tests/a/ad7201a.ada | 98 ++ gcc/testsuite/ada/acats/tests/a/ad7203b.ada | 267 ++++++ gcc/testsuite/ada/acats/tests/a/ad7205b.ada | 64 ++ gcc/testsuite/ada/acats/tests/a/ad8011a.tst | 64 ++ gcc/testsuite/ada/acats/tests/a/ada101a.ada | 101 ++ gcc/testsuite/ada/acats/tests/a/ae2113a.ada | 120 +++ gcc/testsuite/ada/acats/tests/a/ae2113b.ada | 120 +++ gcc/testsuite/ada/acats/tests/a/ae3002g.ada | 47 + gcc/testsuite/ada/acats/tests/a/ae3101a.ada | 135 +++ gcc/testsuite/ada/acats/tests/a/ae3702a.ada | 59 ++ gcc/testsuite/ada/acats/tests/a/ae3709a.ada | 56 ++ gcc/testsuite/ada/acats/tests/c2/c23001a.ada | 64 ++ gcc/testsuite/ada/acats/tests/c2/c23003a.tst | 104 ++ gcc/testsuite/ada/acats/tests/c2/c23003b.tst | 103 ++ gcc/testsuite/ada/acats/tests/c2/c23003g.tst | 129 +++ gcc/testsuite/ada/acats/tests/c2/c23003i.tst | 71 ++ gcc/testsuite/ada/acats/tests/c2/c23006a.ada | 48 + gcc/testsuite/ada/acats/tests/c2/c23006b.ada | 63 ++ gcc/testsuite/ada/acats/tests/c2/c23006c.ada | 75 ++ gcc/testsuite/ada/acats/tests/c2/c23006d.ada | 74 ++ gcc/testsuite/ada/acats/tests/c2/c23006e.ada | 95 ++ gcc/testsuite/ada/acats/tests/c2/c23006f.ada | 57 ++ gcc/testsuite/ada/acats/tests/c2/c23006g.ada | 86 ++ gcc/testsuite/ada/acats/tests/c2/c24002d.ada | 85 ++ gcc/testsuite/ada/acats/tests/c2/c24003a.ada | 61 ++ gcc/testsuite/ada/acats/tests/c2/c24003b.ada | 77 ++ gcc/testsuite/ada/acats/tests/c2/c24003c.ada | 79 ++ gcc/testsuite/ada/acats/tests/c2/c24106a.ada | 63 ++ gcc/testsuite/ada/acats/tests/c2/c24202d.ada | 73 ++ gcc/testsuite/ada/acats/tests/c2/c24203a.ada | 110 +++ gcc/testsuite/ada/acats/tests/c2/c24203b.ada | 113 +++ gcc/testsuite/ada/acats/tests/c2/c24207a.ada | 65 ++ gcc/testsuite/ada/acats/tests/c2/c24211a.ada | 87 ++ gcc/testsuite/ada/acats/tests/c2/c250001.aw | 167 ++++ gcc/testsuite/ada/acats/tests/c2/c250002.aw | 213 +++++ gcc/testsuite/ada/acats/tests/c2/c25001a.ada | 211 +++++ gcc/testsuite/ada/acats/tests/c2/c25001b.ada | 160 ++++ gcc/testsuite/ada/acats/tests/c2/c26006a.ada | 53 ++ gcc/testsuite/ada/acats/tests/c2/c26008a.ada | 51 + gcc/testsuite/ada/acats/tests/c2/c2a001a.ada | 60 ++ gcc/testsuite/ada/acats/tests/c2/c2a001b.ada | 59 ++ gcc/testsuite/ada/acats/tests/c2/c2a001c.ada | 63 ++ gcc/testsuite/ada/acats/tests/c2/c2a002a.ada | 111 +++ gcc/testsuite/ada/acats/tests/c2/c2a008a.ada | 66 ++ gcc/testsuite/ada/acats/tests/c2/c2a021b.ada | 44 + gcc/testsuite/ada/acats/tests/c3/c32001a.ada | 152 +++ gcc/testsuite/ada/acats/tests/c3/c32001b.ada | 249 +++++ gcc/testsuite/ada/acats/tests/c3/c32001c.ada | 125 +++ gcc/testsuite/ada/acats/tests/c3/c32001d.ada | 99 ++ gcc/testsuite/ada/acats/tests/c3/c32001e.ada | 253 +++++ gcc/testsuite/ada/acats/tests/c3/c32107a.ada | 363 +++++++ gcc/testsuite/ada/acats/tests/c3/c32107c.ada | 164 ++++ gcc/testsuite/ada/acats/tests/c3/c32108a.ada | 78 ++ gcc/testsuite/ada/acats/tests/c3/c32108b.ada | 80 ++ gcc/testsuite/ada/acats/tests/c3/c32111a.ada | 282 ++++++ gcc/testsuite/ada/acats/tests/c3/c32111b.ada | 282 ++++++ gcc/testsuite/ada/acats/tests/c3/c32112b.ada | 267 ++++++ gcc/testsuite/ada/acats/tests/c3/c32113a.ada | 534 +++++++++++ gcc/testsuite/ada/acats/tests/c3/c32115a.ada | 338 +++++++ gcc/testsuite/ada/acats/tests/c3/c32115b.ada | 376 ++++++++ gcc/testsuite/ada/acats/tests/c3/c330001.a | 354 +++++++ gcc/testsuite/ada/acats/tests/c3/c330002.a | 326 +++++++ gcc/testsuite/ada/acats/tests/c3/c332001.a | 226 +++++ gcc/testsuite/ada/acats/tests/c3/c340001.a | 470 ++++++++++ gcc/testsuite/ada/acats/tests/c3/c34001a.ada | 186 ++++ gcc/testsuite/ada/acats/tests/c3/c34001c.ada | 150 +++ gcc/testsuite/ada/acats/tests/c3/c34001d.ada | 209 +++++ gcc/testsuite/ada/acats/tests/c3/c34001f.ada | 119 +++ gcc/testsuite/ada/acats/tests/c3/c34002a.ada | 265 ++++++ gcc/testsuite/ada/acats/tests/c3/c34002c.ada | 152 +++ gcc/testsuite/ada/acats/tests/c3/c34003a.ada | 260 +++++ gcc/testsuite/ada/acats/tests/c3/c34003c.ada | 156 +++ gcc/testsuite/ada/acats/tests/c3/c34004a.ada | 267 ++++++ gcc/testsuite/ada/acats/tests/c3/c34004c.ada | 191 ++++ gcc/testsuite/ada/acats/tests/c3/c34005a.ada | 410 ++++++++ gcc/testsuite/ada/acats/tests/c3/c34005c.ada | 195 ++++ gcc/testsuite/ada/acats/tests/c3/c34005d.ada | 425 +++++++++ gcc/testsuite/ada/acats/tests/c3/c34005f.ada | 195 ++++ gcc/testsuite/ada/acats/tests/c3/c34005g.ada | 423 +++++++++ gcc/testsuite/ada/acats/tests/c3/c34005i.ada | 195 ++++ gcc/testsuite/ada/acats/tests/c3/c34005j.ada | 482 ++++++++++ gcc/testsuite/ada/acats/tests/c3/c34005l.ada | 195 ++++ gcc/testsuite/ada/acats/tests/c3/c34005m.ada | 353 +++++++ gcc/testsuite/ada/acats/tests/c3/c34005o.ada | 277 ++++++ gcc/testsuite/ada/acats/tests/c3/c34005p.ada | 405 ++++++++ gcc/testsuite/ada/acats/tests/c3/c34005r.ada | 346 +++++++ gcc/testsuite/ada/acats/tests/c3/c34005s.ada | 404 ++++++++ gcc/testsuite/ada/acats/tests/c3/c34005u.ada | 408 ++++++++ gcc/testsuite/ada/acats/tests/c3/c34005v.ada | 336 +++++++ gcc/testsuite/ada/acats/tests/c3/c34006a.ada | 151 +++ gcc/testsuite/ada/acats/tests/c3/c34006d.ada | 238 +++++ gcc/testsuite/ada/acats/tests/c3/c34006f.ada | 228 +++++ gcc/testsuite/ada/acats/tests/c3/c34006g.ada | 199 ++++ gcc/testsuite/ada/acats/tests/c3/c34006j.ada | 311 ++++++ gcc/testsuite/ada/acats/tests/c3/c34006l.ada | 345 +++++++ gcc/testsuite/ada/acats/tests/c3/c34007a.ada | 181 ++++ gcc/testsuite/ada/acats/tests/c3/c34007d.ada | 266 ++++++ gcc/testsuite/ada/acats/tests/c3/c34007f.ada | 163 ++++ gcc/testsuite/ada/acats/tests/c3/c34007g.ada | 350 +++++++ gcc/testsuite/ada/acats/tests/c3/c34007i.ada | 213 +++++ gcc/testsuite/ada/acats/tests/c3/c34007j.ada | 258 +++++ gcc/testsuite/ada/acats/tests/c3/c34007m.ada | 191 ++++ gcc/testsuite/ada/acats/tests/c3/c34007p.ada | 283 ++++++ gcc/testsuite/ada/acats/tests/c3/c34007r.ada | 218 +++++ gcc/testsuite/ada/acats/tests/c3/c34007s.ada | 299 ++++++ gcc/testsuite/ada/acats/tests/c3/c34007u.ada | 266 ++++++ gcc/testsuite/ada/acats/tests/c3/c34007v.ada | 183 ++++ gcc/testsuite/ada/acats/tests/c3/c34008a.ada | 226 +++++ gcc/testsuite/ada/acats/tests/c3/c34009a.ada | 134 +++ gcc/testsuite/ada/acats/tests/c3/c34009d.ada | 226 +++++ gcc/testsuite/ada/acats/tests/c3/c34009f.ada | 256 +++++ gcc/testsuite/ada/acats/tests/c3/c34009g.ada | 137 +++ gcc/testsuite/ada/acats/tests/c3/c34009j.ada | 225 +++++ gcc/testsuite/ada/acats/tests/c3/c34009l.ada | 270 ++++++ gcc/testsuite/ada/acats/tests/c3/c34011b.ada | 343 +++++++ gcc/testsuite/ada/acats/tests/c3/c34012a.ada | 136 +++ gcc/testsuite/ada/acats/tests/c3/c34014a.ada | 256 +++++ gcc/testsuite/ada/acats/tests/c3/c34014c.ada | 259 +++++ gcc/testsuite/ada/acats/tests/c3/c34014e.ada | 257 +++++ gcc/testsuite/ada/acats/tests/c3/c34014g.ada | 107 +++ gcc/testsuite/ada/acats/tests/c3/c34014h.ada | 208 ++++ gcc/testsuite/ada/acats/tests/c3/c34014n.ada | 256 +++++ gcc/testsuite/ada/acats/tests/c3/c34014p.ada | 258 +++++ gcc/testsuite/ada/acats/tests/c3/c34014r.ada | 257 +++++ gcc/testsuite/ada/acats/tests/c3/c34014t.ada | 107 +++ gcc/testsuite/ada/acats/tests/c3/c34014u.ada | 212 +++++ gcc/testsuite/ada/acats/tests/c3/c34018a.ada | 154 +++ gcc/testsuite/ada/acats/tests/c3/c340a01.a | 165 ++++ gcc/testsuite/ada/acats/tests/c3/c340a02.a | 221 +++++ gcc/testsuite/ada/acats/tests/c3/c341a01.a | 117 +++ gcc/testsuite/ada/acats/tests/c3/c341a02.a | 145 +++ gcc/testsuite/ada/acats/tests/c3/c341a03.a | 140 +++ gcc/testsuite/ada/acats/tests/c3/c341a04.a | 141 +++ gcc/testsuite/ada/acats/tests/c3/c35003a.ada | 234 +++++ gcc/testsuite/ada/acats/tests/c3/c35003b.ada | 217 +++++ gcc/testsuite/ada/acats/tests/c3/c35003d.ada | 92 ++ gcc/testsuite/ada/acats/tests/c3/c35102a.ada | 364 +++++++ gcc/testsuite/ada/acats/tests/c3/c354002.a | 335 +++++++ gcc/testsuite/ada/acats/tests/c3/c354003.a | 211 +++++ gcc/testsuite/ada/acats/tests/c3/c35502a.ada | 71 ++ gcc/testsuite/ada/acats/tests/c3/c35502b.ada | 81 ++ gcc/testsuite/ada/acats/tests/c3/c35502c.ada | 318 +++++++ gcc/testsuite/ada/acats/tests/c3/c35502d.tst | 84 ++ gcc/testsuite/ada/acats/tests/c3/c35502e.ada | 155 +++ gcc/testsuite/ada/acats/tests/c3/c35502f.tst | 89 ++ gcc/testsuite/ada/acats/tests/c3/c35502g.ada | 84 ++ gcc/testsuite/ada/acats/tests/c3/c35502h.ada | 82 ++ gcc/testsuite/ada/acats/tests/c3/c35502i.ada | 91 ++ gcc/testsuite/ada/acats/tests/c3/c35502j.ada | 92 ++ gcc/testsuite/ada/acats/tests/c3/c35502k.ada | 174 ++++ gcc/testsuite/ada/acats/tests/c3/c35502l.ada | 152 +++ gcc/testsuite/ada/acats/tests/c3/c35502m.ada | 177 ++++ gcc/testsuite/ada/acats/tests/c3/c35502n.ada | 158 ++++ gcc/testsuite/ada/acats/tests/c3/c35502o.ada | 52 + gcc/testsuite/ada/acats/tests/c3/c35502p.ada | 122 +++ gcc/testsuite/ada/acats/tests/c3/c35503a.ada | 80 ++ gcc/testsuite/ada/acats/tests/c3/c35503b.ada | 87 ++ gcc/testsuite/ada/acats/tests/c3/c35503c.ada | 543 +++++++++++ gcc/testsuite/ada/acats/tests/c3/c35503d.tst | 97 ++ gcc/testsuite/ada/acats/tests/c3/c35503e.ada | 212 +++++ gcc/testsuite/ada/acats/tests/c3/c35503f.tst | 132 +++ gcc/testsuite/ada/acats/tests/c3/c35503g.ada | 113 +++ gcc/testsuite/ada/acats/tests/c3/c35503h.ada | 94 ++ gcc/testsuite/ada/acats/tests/c3/c35503k.ada | 120 +++ gcc/testsuite/ada/acats/tests/c3/c35503l.ada | 98 ++ gcc/testsuite/ada/acats/tests/c3/c35503o.ada | 125 +++ gcc/testsuite/ada/acats/tests/c3/c35503p.ada | 113 +++ gcc/testsuite/ada/acats/tests/c3/c35504a.ada | 63 ++ gcc/testsuite/ada/acats/tests/c3/c35504b.ada | 85 ++ gcc/testsuite/ada/acats/tests/c3/c35505c.ada | 102 ++ gcc/testsuite/ada/acats/tests/c3/c35505e.ada | 144 +++ gcc/testsuite/ada/acats/tests/c3/c35505f.ada | 164 ++++ gcc/testsuite/ada/acats/tests/c3/c35507a.ada | 88 ++ gcc/testsuite/ada/acats/tests/c3/c35507b.ada | 96 ++ gcc/testsuite/ada/acats/tests/c3/c35507c.ada | 360 +++++++ gcc/testsuite/ada/acats/tests/c3/c35507e.ada | 194 ++++ gcc/testsuite/ada/acats/tests/c3/c35507g.ada | 96 ++ gcc/testsuite/ada/acats/tests/c3/c35507h.ada | 89 ++ gcc/testsuite/ada/acats/tests/c3/c35507i.ada | 84 ++ gcc/testsuite/ada/acats/tests/c3/c35507j.ada | 93 ++ gcc/testsuite/ada/acats/tests/c3/c35507k.ada | 224 +++++ gcc/testsuite/ada/acats/tests/c3/c35507l.ada | 101 ++ gcc/testsuite/ada/acats/tests/c3/c35507m.ada | 159 ++++ gcc/testsuite/ada/acats/tests/c3/c35507n.ada | 108 +++ gcc/testsuite/ada/acats/tests/c3/c35507o.ada | 120 +++ gcc/testsuite/ada/acats/tests/c3/c35507p.ada | 94 ++ gcc/testsuite/ada/acats/tests/c3/c35508a.ada | 74 ++ gcc/testsuite/ada/acats/tests/c3/c35508b.ada | 79 ++ gcc/testsuite/ada/acats/tests/c3/c35508c.ada | 195 ++++ gcc/testsuite/ada/acats/tests/c3/c35508e.ada | 192 ++++ gcc/testsuite/ada/acats/tests/c3/c35508g.ada | 105 +++ gcc/testsuite/ada/acats/tests/c3/c35508h.ada | 116 +++ gcc/testsuite/ada/acats/tests/c3/c35508k.ada | 125 +++ gcc/testsuite/ada/acats/tests/c3/c35508l.ada | 132 +++ gcc/testsuite/ada/acats/tests/c3/c35508o.ada | 98 ++ gcc/testsuite/ada/acats/tests/c3/c35508p.ada | 131 +++ gcc/testsuite/ada/acats/tests/c3/c35703a.ada | 142 +++ gcc/testsuite/ada/acats/tests/c3/c35704a.ada | 60 ++ gcc/testsuite/ada/acats/tests/c3/c35704b.ada | 62 ++ gcc/testsuite/ada/acats/tests/c3/c35704c.ada | 62 ++ gcc/testsuite/ada/acats/tests/c3/c35704d.ada | 70 ++ gcc/testsuite/ada/acats/tests/c3/c35801d.ada | 79 ++ gcc/testsuite/ada/acats/tests/c3/c35902d.ada | 121 +++ gcc/testsuite/ada/acats/tests/c3/c35904a.ada | 103 ++ gcc/testsuite/ada/acats/tests/c3/c35904b.ada | 136 +++ gcc/testsuite/ada/acats/tests/c3/c35a02a.ada | 75 ++ gcc/testsuite/ada/acats/tests/c3/c35a05a.ada | 153 +++ gcc/testsuite/ada/acats/tests/c3/c35a05d.ada | 153 +++ gcc/testsuite/ada/acats/tests/c3/c35a05n.ada | 160 ++++ gcc/testsuite/ada/acats/tests/c3/c35a05q.ada | 184 ++++ gcc/testsuite/ada/acats/tests/c3/c35a07a.ada | 129 +++ gcc/testsuite/ada/acats/tests/c3/c35a07d.ada | 191 ++++ gcc/testsuite/ada/acats/tests/c3/c35a08b.ada | 91 ++ gcc/testsuite/ada/acats/tests/c3/c360002.a | 268 ++++++ gcc/testsuite/ada/acats/tests/c3/c36104a.ada | 359 +++++++ gcc/testsuite/ada/acats/tests/c3/c36104b.ada | 421 +++++++++ gcc/testsuite/ada/acats/tests/c3/c36172a.ada | 250 +++++ gcc/testsuite/ada/acats/tests/c3/c36172b.ada | 161 ++++ gcc/testsuite/ada/acats/tests/c3/c36172c.ada | 58 ++ gcc/testsuite/ada/acats/tests/c3/c36174a.ada | 118 +++ gcc/testsuite/ada/acats/tests/c3/c36180a.ada | 136 +++ gcc/testsuite/ada/acats/tests/c3/c36202c.ada | 87 ++ gcc/testsuite/ada/acats/tests/c3/c36203a.ada | 76 ++ gcc/testsuite/ada/acats/tests/c3/c36204a.ada | 142 +++ gcc/testsuite/ada/acats/tests/c3/c36204b.ada | 229 +++++ gcc/testsuite/ada/acats/tests/c3/c36204c.ada | 221 +++++ gcc/testsuite/ada/acats/tests/c3/c36204d.ada | 598 ++++++++++++ gcc/testsuite/ada/acats/tests/c3/c36205a.ada | 212 +++++ gcc/testsuite/ada/acats/tests/c3/c36205b.ada | 169 ++++ gcc/testsuite/ada/acats/tests/c3/c36205c.ada | 165 ++++ gcc/testsuite/ada/acats/tests/c3/c36205d.ada | 180 ++++ gcc/testsuite/ada/acats/tests/c3/c36205e.ada | 164 ++++ gcc/testsuite/ada/acats/tests/c3/c36205f.ada | 165 ++++ gcc/testsuite/ada/acats/tests/c3/c36205g.ada | 165 ++++ gcc/testsuite/ada/acats/tests/c3/c36205h.ada | 166 ++++ gcc/testsuite/ada/acats/tests/c3/c36205i.ada | 167 ++++ gcc/testsuite/ada/acats/tests/c3/c36205j.ada | 180 ++++ gcc/testsuite/ada/acats/tests/c3/c36205k.ada | 173 ++++ gcc/testsuite/ada/acats/tests/c3/c36205l.ada | 288 ++++++ gcc/testsuite/ada/acats/tests/c3/c36301a.ada | 149 +++ gcc/testsuite/ada/acats/tests/c3/c36301b.ada | 55 ++ gcc/testsuite/ada/acats/tests/c3/c36302a.ada | 53 ++ gcc/testsuite/ada/acats/tests/c3/c36304a.ada | 91 ++ gcc/testsuite/ada/acats/tests/c3/c36305a.ada | 117 +++ gcc/testsuite/ada/acats/tests/c3/c37002a.ada | 79 ++ gcc/testsuite/ada/acats/tests/c3/c37003a.ada | 198 ++++ gcc/testsuite/ada/acats/tests/c3/c37003b.ada | 66 ++ gcc/testsuite/ada/acats/tests/c3/c37005a.ada | 92 ++ gcc/testsuite/ada/acats/tests/c3/c37006a.ada | 272 ++++++ gcc/testsuite/ada/acats/tests/c3/c37008a.ada | 270 ++++++ gcc/testsuite/ada/acats/tests/c3/c37008b.ada | 232 +++++ gcc/testsuite/ada/acats/tests/c3/c37009a.ada | 195 ++++ gcc/testsuite/ada/acats/tests/c3/c37010a.ada | 140 +++ gcc/testsuite/ada/acats/tests/c3/c37010b.ada | 164 ++++ gcc/testsuite/ada/acats/tests/c3/c371001.a | 388 ++++++++ gcc/testsuite/ada/acats/tests/c3/c371002.a | 364 +++++++ gcc/testsuite/ada/acats/tests/c3/c371003.a | 474 ++++++++++ gcc/testsuite/ada/acats/tests/c3/c37102b.ada | 109 +++ gcc/testsuite/ada/acats/tests/c3/c37103a.ada | 83 ++ gcc/testsuite/ada/acats/tests/c3/c37105a.ada | 55 ++ gcc/testsuite/ada/acats/tests/c3/c37107a.ada | 154 +++ gcc/testsuite/ada/acats/tests/c3/c37108b.ada | 247 +++++ gcc/testsuite/ada/acats/tests/c3/c37206a.ada | 65 ++ gcc/testsuite/ada/acats/tests/c3/c37207a.ada | 230 +++++ gcc/testsuite/ada/acats/tests/c3/c37208a.ada | 172 ++++ gcc/testsuite/ada/acats/tests/c3/c37208b.ada | 120 +++ gcc/testsuite/ada/acats/tests/c3/c37209a.ada | 145 +++ gcc/testsuite/ada/acats/tests/c3/c37209b.ada | 194 ++++ gcc/testsuite/ada/acats/tests/c3/c37210a.ada | 116 +++ gcc/testsuite/ada/acats/tests/c3/c37211a.ada | 242 +++++ gcc/testsuite/ada/acats/tests/c3/c37211b.ada | 495 ++++++++++ gcc/testsuite/ada/acats/tests/c3/c37211c.ada | 426 +++++++++ gcc/testsuite/ada/acats/tests/c3/c37211d.ada | 102 ++ gcc/testsuite/ada/acats/tests/c3/c37211e.ada | 233 +++++ gcc/testsuite/ada/acats/tests/c3/c37213b.ada | 241 +++++ gcc/testsuite/ada/acats/tests/c3/c37213d.ada | 240 +++++ gcc/testsuite/ada/acats/tests/c3/c37213f.ada | 379 ++++++++ gcc/testsuite/ada/acats/tests/c3/c37213h.ada | 457 +++++++++ gcc/testsuite/ada/acats/tests/c3/c37213j.ada | 320 +++++++ gcc/testsuite/ada/acats/tests/c3/c37213k.ada | 324 +++++++ gcc/testsuite/ada/acats/tests/c3/c37213l.ada | 329 +++++++ gcc/testsuite/ada/acats/tests/c3/c37215b.ada | 203 ++++ gcc/testsuite/ada/acats/tests/c3/c37215d.ada | 202 ++++ gcc/testsuite/ada/acats/tests/c3/c37215f.ada | 313 +++++++ gcc/testsuite/ada/acats/tests/c3/c37215h.ada | 345 +++++++ gcc/testsuite/ada/acats/tests/c3/c37217a.ada | 128 +++ gcc/testsuite/ada/acats/tests/c3/c37217b.ada | 132 +++ gcc/testsuite/ada/acats/tests/c3/c37217c.ada | 100 ++ gcc/testsuite/ada/acats/tests/c3/c37304a.ada | 92 ++ gcc/testsuite/ada/acats/tests/c3/c37305a.ada | 82 ++ gcc/testsuite/ada/acats/tests/c3/c37306a.ada | 70 ++ gcc/testsuite/ada/acats/tests/c3/c37309a.ada | 74 ++ gcc/testsuite/ada/acats/tests/c3/c37310a.ada | 124 +++ gcc/testsuite/ada/acats/tests/c3/c37312a.ada | 87 ++ gcc/testsuite/ada/acats/tests/c3/c37402a.ada | 253 +++++ gcc/testsuite/ada/acats/tests/c3/c37403a.ada | 186 ++++ gcc/testsuite/ada/acats/tests/c3/c37404a.ada | 168 ++++ gcc/testsuite/ada/acats/tests/c3/c37404b.ada | 148 +++ gcc/testsuite/ada/acats/tests/c3/c37405a.ada | 161 ++++ gcc/testsuite/ada/acats/tests/c3/c37411a.ada | 82 ++ gcc/testsuite/ada/acats/tests/c3/c380001.a | 128 +++ gcc/testsuite/ada/acats/tests/c3/c380002.a | 72 ++ gcc/testsuite/ada/acats/tests/c3/c380003.a | 223 +++++ gcc/testsuite/ada/acats/tests/c3/c380004.a | 385 ++++++++ gcc/testsuite/ada/acats/tests/c3/c38002a.ada | 420 +++++++++ gcc/testsuite/ada/acats/tests/c3/c38002b.ada | 123 +++ gcc/testsuite/ada/acats/tests/c3/c38005a.ada | 170 ++++ gcc/testsuite/ada/acats/tests/c3/c38005b.ada | 98 ++ gcc/testsuite/ada/acats/tests/c3/c38005c.ada | 156 +++ gcc/testsuite/ada/acats/tests/c3/c38006a.ada | 50 + gcc/testsuite/ada/acats/tests/c3/c38102a.ada | 158 ++++ gcc/testsuite/ada/acats/tests/c3/c38102b.ada | 56 ++ gcc/testsuite/ada/acats/tests/c3/c38102c.ada | 60 ++ gcc/testsuite/ada/acats/tests/c3/c38102d.ada | 54 ++ gcc/testsuite/ada/acats/tests/c3/c38102e.ada | 164 ++++ gcc/testsuite/ada/acats/tests/c3/c38104a.ada | 97 ++ gcc/testsuite/ada/acats/tests/c3/c38107a.ada | 105 +++ gcc/testsuite/ada/acats/tests/c3/c38107b.ada | 194 ++++ gcc/testsuite/ada/acats/tests/c3/c38108a.ada | 77 ++ gcc/testsuite/ada/acats/tests/c3/c38108b.ada | 76 ++ gcc/testsuite/ada/acats/tests/c3/c38108c0.ada | 36 + gcc/testsuite/ada/acats/tests/c3/c38108c1.ada | 52 + gcc/testsuite/ada/acats/tests/c3/c38108c2.ada | 47 + gcc/testsuite/ada/acats/tests/c3/c38108d0.ada | 65 ++ gcc/testsuite/ada/acats/tests/c3/c38108d1.ada | 47 + gcc/testsuite/ada/acats/tests/c3/c38202a.ada | 197 ++++ gcc/testsuite/ada/acats/tests/c3/c3900010.a | 147 +++ gcc/testsuite/ada/acats/tests/c3/c3900011.am | 253 +++++ gcc/testsuite/ada/acats/tests/c3/c390002.a | 165 ++++ gcc/testsuite/ada/acats/tests/c3/c390003.a | 419 +++++++++ gcc/testsuite/ada/acats/tests/c3/c390004.a | 404 ++++++++ gcc/testsuite/ada/acats/tests/c3/c3900050.a | 157 ++++ gcc/testsuite/ada/acats/tests/c3/c3900051.a | 137 +++ gcc/testsuite/ada/acats/tests/c3/c3900052.a | 138 +++ gcc/testsuite/ada/acats/tests/c3/c3900053.am | 191 ++++ gcc/testsuite/ada/acats/tests/c3/c3900060.a | 159 ++++ gcc/testsuite/ada/acats/tests/c3/c3900061.a | 138 +++ gcc/testsuite/ada/acats/tests/c3/c3900062.a | 137 +++ gcc/testsuite/ada/acats/tests/c3/c3900063.am | 138 +++ gcc/testsuite/ada/acats/tests/c3/c390007.a | 374 ++++++++ gcc/testsuite/ada/acats/tests/c3/c390010.a | 216 +++++ gcc/testsuite/ada/acats/tests/c3/c390011.a | 250 +++++ gcc/testsuite/ada/acats/tests/c3/c39006a.ada | 207 ++++ gcc/testsuite/ada/acats/tests/c3/c39006b.ada | 163 ++++ gcc/testsuite/ada/acats/tests/c3/c39006c0.ada | 69 ++ gcc/testsuite/ada/acats/tests/c3/c39006c1.ada | 41 + gcc/testsuite/ada/acats/tests/c3/c39006d.ada | 144 +++ gcc/testsuite/ada/acats/tests/c3/c39006e.ada | 213 +++++ gcc/testsuite/ada/acats/tests/c3/c39006f0.ada | 44 + gcc/testsuite/ada/acats/tests/c3/c39006f1.ada | 42 + gcc/testsuite/ada/acats/tests/c3/c39006f2.ada | 130 +++ gcc/testsuite/ada/acats/tests/c3/c39006f3.ada | 49 + gcc/testsuite/ada/acats/tests/c3/c39006g.ada | 71 ++ gcc/testsuite/ada/acats/tests/c3/c39007a.ada | 132 +++ gcc/testsuite/ada/acats/tests/c3/c39007b.ada | 83 ++ gcc/testsuite/ada/acats/tests/c3/c39008a.ada | 73 ++ gcc/testsuite/ada/acats/tests/c3/c39008b.ada | 77 ++ gcc/testsuite/ada/acats/tests/c3/c39008c.ada | 97 ++ gcc/testsuite/ada/acats/tests/c3/c390a010.a | 127 +++ gcc/testsuite/ada/acats/tests/c3/c390a011.am | 218 +++++ gcc/testsuite/ada/acats/tests/c3/c390a020.a | 90 ++ gcc/testsuite/ada/acats/tests/c3/c390a021.a | 133 +++ gcc/testsuite/ada/acats/tests/c3/c390a022.am | 179 ++++ gcc/testsuite/ada/acats/tests/c3/c390a030.a | 188 ++++ gcc/testsuite/ada/acats/tests/c3/c390a031.am | 167 ++++ gcc/testsuite/ada/acats/tests/c3/c391001.a | 329 +++++++ gcc/testsuite/ada/acats/tests/c3/c391002.a | 493 ++++++++++ gcc/testsuite/ada/acats/tests/c3/c392002.a | 349 +++++++ gcc/testsuite/ada/acats/tests/c3/c392003.a | 453 +++++++++ gcc/testsuite/ada/acats/tests/c3/c392004.a | 189 ++++ gcc/testsuite/ada/acats/tests/c3/c392005.a | 367 ++++++++ gcc/testsuite/ada/acats/tests/c3/c392008.a | 401 ++++++++ gcc/testsuite/ada/acats/tests/c3/c392010.a | 512 ++++++++++ gcc/testsuite/ada/acats/tests/c3/c392011.a | 299 ++++++ gcc/testsuite/ada/acats/tests/c3/c392013.a | 179 ++++ gcc/testsuite/ada/acats/tests/c3/c392014.a | 227 +++++ gcc/testsuite/ada/acats/tests/c3/c392a01.a | 265 ++++++ gcc/testsuite/ada/acats/tests/c3/c392c05.a | 164 ++++ gcc/testsuite/ada/acats/tests/c3/c392c07.a | 190 ++++ gcc/testsuite/ada/acats/tests/c3/c392d01.a | 324 +++++++ gcc/testsuite/ada/acats/tests/c3/c392d02.a | 185 ++++ gcc/testsuite/ada/acats/tests/c3/c392d03.a | 248 +++++ gcc/testsuite/ada/acats/tests/c3/c393001.a | 407 ++++++++ gcc/testsuite/ada/acats/tests/c3/c393007.a | 157 ++++ gcc/testsuite/ada/acats/tests/c3/c393008.a | 204 ++++ gcc/testsuite/ada/acats/tests/c3/c393009.a | 170 ++++ gcc/testsuite/ada/acats/tests/c3/c393010.a | 306 ++++++ gcc/testsuite/ada/acats/tests/c3/c393011.a | 220 +++++ gcc/testsuite/ada/acats/tests/c3/c393012.a | 221 +++++ gcc/testsuite/ada/acats/tests/c3/c393a02.a | 213 +++++ gcc/testsuite/ada/acats/tests/c3/c393a03.a | 242 +++++ gcc/testsuite/ada/acats/tests/c3/c393a05.a | 166 ++++ gcc/testsuite/ada/acats/tests/c3/c393a06.a | 201 ++++ gcc/testsuite/ada/acats/tests/c3/c393b12.a | 131 +++ gcc/testsuite/ada/acats/tests/c3/c393b13.a | 105 +++ gcc/testsuite/ada/acats/tests/c3/c393b14.a | 147 +++ gcc/testsuite/ada/acats/tests/c3/c3a0001.a | 138 +++ gcc/testsuite/ada/acats/tests/c3/c3a0002.a | 142 +++ gcc/testsuite/ada/acats/tests/c3/c3a0003.a | 144 +++ gcc/testsuite/ada/acats/tests/c3/c3a0004.a | 115 +++ gcc/testsuite/ada/acats/tests/c3/c3a0005.a | 147 +++ gcc/testsuite/ada/acats/tests/c3/c3a0006.a | 163 ++++ gcc/testsuite/ada/acats/tests/c3/c3a0007.a | 234 +++++ gcc/testsuite/ada/acats/tests/c3/c3a0008.a | 150 +++ gcc/testsuite/ada/acats/tests/c3/c3a0009.a | 219 +++++ gcc/testsuite/ada/acats/tests/c3/c3a0010.a | 158 ++++ gcc/testsuite/ada/acats/tests/c3/c3a0011.a | 186 ++++ gcc/testsuite/ada/acats/tests/c3/c3a00120.a | 83 ++ gcc/testsuite/ada/acats/tests/c3/c3a00121.a | 76 ++ gcc/testsuite/ada/acats/tests/c3/c3a00122.am | 113 +++ gcc/testsuite/ada/acats/tests/c3/c3a0013.a | 347 +++++++ gcc/testsuite/ada/acats/tests/c3/c3a0014.a | 453 +++++++++ gcc/testsuite/ada/acats/tests/c3/c3a0015.a | 267 ++++++ gcc/testsuite/ada/acats/tests/c3/c3a1001.a | 315 +++++++ gcc/testsuite/ada/acats/tests/c3/c3a1002.a | 251 +++++ gcc/testsuite/ada/acats/tests/c3/c3a2001.a | 460 +++++++++ gcc/testsuite/ada/acats/tests/c3/c3a2002.a | 295 ++++++ gcc/testsuite/ada/acats/tests/c3/c3a2003.a | 329 +++++++ gcc/testsuite/ada/acats/tests/c3/c3a2a01.a | 367 ++++++++ gcc/testsuite/ada/acats/tests/c3/c3a2a02.a | 396 ++++++++ gcc/testsuite/ada/acats/tests/c4/c410001.a | 303 ++++++ gcc/testsuite/ada/acats/tests/c4/c41101d.ada | 102 ++ gcc/testsuite/ada/acats/tests/c4/c41103a.ada | 239 +++++ gcc/testsuite/ada/acats/tests/c4/c41103b.ada | 366 ++++++++ gcc/testsuite/ada/acats/tests/c4/c41104a.ada | 240 +++++ gcc/testsuite/ada/acats/tests/c4/c41105a.ada | 104 ++ gcc/testsuite/ada/acats/tests/c4/c41107a.ada | 142 +++ gcc/testsuite/ada/acats/tests/c4/c41201d.ada | 105 +++ gcc/testsuite/ada/acats/tests/c4/c41203a.ada | 241 +++++ gcc/testsuite/ada/acats/tests/c4/c41203b.ada | 378 ++++++++ gcc/testsuite/ada/acats/tests/c4/c41204a.ada | 86 ++ gcc/testsuite/ada/acats/tests/c4/c41205a.ada | 94 ++ gcc/testsuite/ada/acats/tests/c4/c41206a.ada | 84 ++ gcc/testsuite/ada/acats/tests/c4/c41207a.ada | 69 ++ gcc/testsuite/ada/acats/tests/c4/c41301a.ada | 216 +++++ gcc/testsuite/ada/acats/tests/c4/c41303a.ada | 120 +++ gcc/testsuite/ada/acats/tests/c4/c41303b.ada | 117 +++ gcc/testsuite/ada/acats/tests/c4/c41303c.ada | 116 +++ gcc/testsuite/ada/acats/tests/c4/c41303e.ada | 124 +++ gcc/testsuite/ada/acats/tests/c4/c41303f.ada | 117 +++ gcc/testsuite/ada/acats/tests/c4/c41303g.ada | 121 +++ gcc/testsuite/ada/acats/tests/c4/c41303i.ada | 127 +++ gcc/testsuite/ada/acats/tests/c4/c41303j.ada | 122 +++ gcc/testsuite/ada/acats/tests/c4/c41303k.ada | 124 +++ gcc/testsuite/ada/acats/tests/c4/c41303m.ada | 150 +++ gcc/testsuite/ada/acats/tests/c4/c41303n.ada | 147 +++ gcc/testsuite/ada/acats/tests/c4/c41303o.ada | 145 +++ gcc/testsuite/ada/acats/tests/c4/c41303q.ada | 152 +++ gcc/testsuite/ada/acats/tests/c4/c41303r.ada | 145 +++ gcc/testsuite/ada/acats/tests/c4/c41303s.ada | 151 +++ gcc/testsuite/ada/acats/tests/c4/c41303u.ada | 158 ++++ gcc/testsuite/ada/acats/tests/c4/c41303v.ada | 155 +++ gcc/testsuite/ada/acats/tests/c4/c41303w.ada | 159 ++++ gcc/testsuite/ada/acats/tests/c4/c41304a.ada | 119 +++ gcc/testsuite/ada/acats/tests/c4/c41304b.ada | 198 ++++ gcc/testsuite/ada/acats/tests/c4/c41306a.ada | 104 ++ gcc/testsuite/ada/acats/tests/c4/c41306b.ada | 217 +++++ gcc/testsuite/ada/acats/tests/c4/c41306c.ada | 215 +++++ gcc/testsuite/ada/acats/tests/c4/c41307d.ada | 255 +++++ gcc/testsuite/ada/acats/tests/c4/c41309a.ada | 69 ++ gcc/testsuite/ada/acats/tests/c4/c41320a.ada | 97 ++ gcc/testsuite/ada/acats/tests/c4/c41321a.ada | 106 +++ gcc/testsuite/ada/acats/tests/c4/c41322a.ada | 125 +++ gcc/testsuite/ada/acats/tests/c4/c41323a.ada | 125 +++ gcc/testsuite/ada/acats/tests/c4/c41324a.ada | 120 +++ gcc/testsuite/ada/acats/tests/c4/c41325a.ada | 173 ++++ gcc/testsuite/ada/acats/tests/c4/c41326a.ada | 72 ++ gcc/testsuite/ada/acats/tests/c4/c41327a.ada | 84 ++ gcc/testsuite/ada/acats/tests/c4/c41328a.ada | 100 ++ gcc/testsuite/ada/acats/tests/c4/c41401a.ada | 216 +++++ gcc/testsuite/ada/acats/tests/c4/c41402a.ada | 118 +++ gcc/testsuite/ada/acats/tests/c4/c41404a.ada | 136 +++ gcc/testsuite/ada/acats/tests/c4/c420001.a | 110 +++ gcc/testsuite/ada/acats/tests/c4/c42006a.ada | 99 ++ gcc/testsuite/ada/acats/tests/c4/c42007e.ada | 117 +++ gcc/testsuite/ada/acats/tests/c4/c43003a.ada | 64 ++ gcc/testsuite/ada/acats/tests/c4/c43004a.ada | 350 +++++++ gcc/testsuite/ada/acats/tests/c4/c43004c.ada | 230 +++++ gcc/testsuite/ada/acats/tests/c4/c431001.a | 464 +++++++++ gcc/testsuite/ada/acats/tests/c4/c43103a.ada | 127 +++ gcc/testsuite/ada/acats/tests/c4/c43103b.ada | 186 ++++ gcc/testsuite/ada/acats/tests/c4/c43104a.ada | 86 ++ gcc/testsuite/ada/acats/tests/c4/c43105a.ada | 97 ++ gcc/testsuite/ada/acats/tests/c4/c43105b.ada | 94 ++ gcc/testsuite/ada/acats/tests/c4/c43106a.ada | 90 ++ gcc/testsuite/ada/acats/tests/c4/c43107a.ada | 125 +++ gcc/testsuite/ada/acats/tests/c4/c43108a.ada | 111 +++ gcc/testsuite/ada/acats/tests/c4/c432001.a | 512 ++++++++++ gcc/testsuite/ada/acats/tests/c4/c432002.a | 764 +++++++++++++++ gcc/testsuite/ada/acats/tests/c4/c432003.a | 594 ++++++++++++ gcc/testsuite/ada/acats/tests/c4/c432004.a | 319 +++++++ gcc/testsuite/ada/acats/tests/c4/c43204a.ada | 158 ++++ gcc/testsuite/ada/acats/tests/c4/c43204c.ada | 192 ++++ gcc/testsuite/ada/acats/tests/c4/c43204e.ada | 179 ++++ gcc/testsuite/ada/acats/tests/c4/c43204f.ada | 107 +++ gcc/testsuite/ada/acats/tests/c4/c43204g.ada | 125 +++ gcc/testsuite/ada/acats/tests/c4/c43204h.ada | 107 +++ gcc/testsuite/ada/acats/tests/c4/c43204i.ada | 106 +++ gcc/testsuite/ada/acats/tests/c4/c43205a.ada | 111 +++ gcc/testsuite/ada/acats/tests/c4/c43205b.ada | 82 ++ gcc/testsuite/ada/acats/tests/c4/c43205c.ada | 83 ++ gcc/testsuite/ada/acats/tests/c4/c43205d.ada | 73 ++ gcc/testsuite/ada/acats/tests/c4/c43205e.ada | 117 +++ gcc/testsuite/ada/acats/tests/c4/c43205g.ada | 105 +++ gcc/testsuite/ada/acats/tests/c4/c43205h.ada | 82 ++ gcc/testsuite/ada/acats/tests/c4/c43205i.ada | 83 ++ gcc/testsuite/ada/acats/tests/c4/c43205j.ada | 146 +++ gcc/testsuite/ada/acats/tests/c4/c43205k.ada | 110 +++ gcc/testsuite/ada/acats/tests/c4/c43206a.ada | 242 +++++ gcc/testsuite/ada/acats/tests/c4/c43207b.ada | 149 +++ gcc/testsuite/ada/acats/tests/c4/c43207d.ada | 135 +++ gcc/testsuite/ada/acats/tests/c4/c43208a.ada | 208 ++++ gcc/testsuite/ada/acats/tests/c4/c43208b.ada | 266 ++++++ gcc/testsuite/ada/acats/tests/c4/c43209a.ada | 135 +++ gcc/testsuite/ada/acats/tests/c4/c43210a.ada | 142 +++ gcc/testsuite/ada/acats/tests/c4/c43211a.ada | 170 ++++ gcc/testsuite/ada/acats/tests/c4/c43212a.ada | 154 +++ gcc/testsuite/ada/acats/tests/c4/c43212c.ada | 102 ++ gcc/testsuite/ada/acats/tests/c4/c43214a.ada | 100 ++ gcc/testsuite/ada/acats/tests/c4/c43214b.ada | 105 +++ gcc/testsuite/ada/acats/tests/c4/c43214c.ada | 75 ++ gcc/testsuite/ada/acats/tests/c4/c43214d.ada | 77 ++ gcc/testsuite/ada/acats/tests/c4/c43214e.ada | 147 +++ gcc/testsuite/ada/acats/tests/c4/c43214f.ada | 151 +++ gcc/testsuite/ada/acats/tests/c4/c43215a.ada | 138 +++ gcc/testsuite/ada/acats/tests/c4/c43215b.ada | 142 +++ gcc/testsuite/ada/acats/tests/c4/c43222a.ada | 49 + gcc/testsuite/ada/acats/tests/c4/c43224a.ada | 75 ++ gcc/testsuite/ada/acats/tests/c4/c433001.a | 302 ++++++ gcc/testsuite/ada/acats/tests/c4/c44003d.ada | 188 ++++ gcc/testsuite/ada/acats/tests/c4/c44003f.ada | 143 +++ gcc/testsuite/ada/acats/tests/c4/c44003g.ada | 134 +++ gcc/testsuite/ada/acats/tests/c4/c450001.a | 434 +++++++++ gcc/testsuite/ada/acats/tests/c4/c45112a.ada | 233 +++++ gcc/testsuite/ada/acats/tests/c4/c45112b.ada | 234 +++++ gcc/testsuite/ada/acats/tests/c4/c45113a.ada | 91 ++ gcc/testsuite/ada/acats/tests/c4/c45114b.ada | 73 ++ gcc/testsuite/ada/acats/tests/c4/c452001.a | 707 ++++++++++++++ gcc/testsuite/ada/acats/tests/c4/c45201a.ada | 242 +++++ gcc/testsuite/ada/acats/tests/c4/c45201b.ada | 236 +++++ gcc/testsuite/ada/acats/tests/c4/c45202b.ada | 95 ++ gcc/testsuite/ada/acats/tests/c4/c45210a.ada | 191 ++++ gcc/testsuite/ada/acats/tests/c4/c45211a.ada | 66 ++ gcc/testsuite/ada/acats/tests/c4/c45220a.ada | 129 +++ gcc/testsuite/ada/acats/tests/c4/c45220b.ada | 191 ++++ gcc/testsuite/ada/acats/tests/c4/c45220c.ada | 138 +++ gcc/testsuite/ada/acats/tests/c4/c45220d.ada | 200 ++++ gcc/testsuite/ada/acats/tests/c4/c45220e.ada | 74 ++ gcc/testsuite/ada/acats/tests/c4/c45220f.ada | 67 ++ gcc/testsuite/ada/acats/tests/c4/c45231a.ada | 252 +++++ gcc/testsuite/ada/acats/tests/c4/c45231b.dep | 265 ++++++ gcc/testsuite/ada/acats/tests/c4/c45231c.dep | 265 ++++++ gcc/testsuite/ada/acats/tests/c4/c45231d.tst | 274 ++++++ gcc/testsuite/ada/acats/tests/c4/c45232b.ada | 135 +++ gcc/testsuite/ada/acats/tests/c4/c45242b.ada | 148 +++ gcc/testsuite/ada/acats/tests/c4/c45251a.ada | 178 ++++ gcc/testsuite/ada/acats/tests/c4/c45252a.ada | 200 ++++ gcc/testsuite/ada/acats/tests/c4/c45252b.ada | 146 +++ gcc/testsuite/ada/acats/tests/c4/c45253a.ada | 97 ++ gcc/testsuite/ada/acats/tests/c4/c45262a.ada | 214 +++++ gcc/testsuite/ada/acats/tests/c4/c45262b.ada | 219 +++++ gcc/testsuite/ada/acats/tests/c4/c45262c.ada | 216 +++++ gcc/testsuite/ada/acats/tests/c4/c45262d.ada | 105 +++ gcc/testsuite/ada/acats/tests/c4/c45264a.ada | 109 +++ gcc/testsuite/ada/acats/tests/c4/c45264b.ada | 88 ++ gcc/testsuite/ada/acats/tests/c4/c45264c.ada | 153 +++ gcc/testsuite/ada/acats/tests/c4/c45265a.ada | 196 ++++ gcc/testsuite/ada/acats/tests/c4/c45271a.ada | 112 +++ gcc/testsuite/ada/acats/tests/c4/c45272a.ada | 105 +++ gcc/testsuite/ada/acats/tests/c4/c45273a.ada | 133 +++ gcc/testsuite/ada/acats/tests/c4/c45274a.ada | 222 +++++ gcc/testsuite/ada/acats/tests/c4/c45274b.ada | 229 +++++ gcc/testsuite/ada/acats/tests/c4/c45274c.ada | 187 ++++ gcc/testsuite/ada/acats/tests/c4/c45281a.ada | 84 ++ gcc/testsuite/ada/acats/tests/c4/c45282a.ada | 170 ++++ gcc/testsuite/ada/acats/tests/c4/c45282b.ada | 347 +++++++ gcc/testsuite/ada/acats/tests/c4/c45291a.ada | 158 ++++ gcc/testsuite/ada/acats/tests/c4/c45303a.ada | 80 ++ gcc/testsuite/ada/acats/tests/c4/c45304a.ada | 82 ++ gcc/testsuite/ada/acats/tests/c4/c45304b.dep | 111 +++ gcc/testsuite/ada/acats/tests/c4/c45304c.dep | 110 +++ gcc/testsuite/ada/acats/tests/c4/c45322a.ada | 196 ++++ gcc/testsuite/ada/acats/tests/c4/c45323a.ada | 67 ++ gcc/testsuite/ada/acats/tests/c4/c45331a.ada | 357 +++++++ gcc/testsuite/ada/acats/tests/c4/c45342a.ada | 99 ++ gcc/testsuite/ada/acats/tests/c4/c45343a.ada | 75 ++ gcc/testsuite/ada/acats/tests/c4/c45344a.ada | 116 +++ gcc/testsuite/ada/acats/tests/c4/c45345b.ada | 118 +++ gcc/testsuite/ada/acats/tests/c4/c45347a.ada | 96 ++ gcc/testsuite/ada/acats/tests/c4/c45347b.ada | 90 ++ gcc/testsuite/ada/acats/tests/c4/c45347c.ada | 108 +++ gcc/testsuite/ada/acats/tests/c4/c45347d.ada | 93 ++ gcc/testsuite/ada/acats/tests/c4/c45411a.ada | 120 +++ gcc/testsuite/ada/acats/tests/c4/c45411b.dep | 123 +++ gcc/testsuite/ada/acats/tests/c4/c45411c.dep | 123 +++ gcc/testsuite/ada/acats/tests/c4/c45411d.ada | 98 ++ gcc/testsuite/ada/acats/tests/c4/c45413a.ada | 74 ++ gcc/testsuite/ada/acats/tests/c4/c45431a.ada | 212 +++++ gcc/testsuite/ada/acats/tests/c4/c455001.a | 164 ++++ gcc/testsuite/ada/acats/tests/c4/c45502b.dep | 291 ++++++ gcc/testsuite/ada/acats/tests/c4/c45502c.dep | 295 ++++++ gcc/testsuite/ada/acats/tests/c4/c45503a.ada | 310 ++++++ gcc/testsuite/ada/acats/tests/c4/c45503b.dep | 327 +++++++ gcc/testsuite/ada/acats/tests/c4/c45503c.dep | 331 +++++++ gcc/testsuite/ada/acats/tests/c4/c45504a.ada | 92 ++ gcc/testsuite/ada/acats/tests/c4/c45504b.dep | 117 +++ gcc/testsuite/ada/acats/tests/c4/c45504c.dep | 119 +++ gcc/testsuite/ada/acats/tests/c4/c45504d.ada | 214 +++++ gcc/testsuite/ada/acats/tests/c4/c45504e.dep | 234 +++++ gcc/testsuite/ada/acats/tests/c4/c45504f.dep | 234 +++++ gcc/testsuite/ada/acats/tests/c4/c45505a.ada | 65 ++ gcc/testsuite/ada/acats/tests/c4/c45523a.ada | 111 +++ gcc/testsuite/ada/acats/tests/c4/c45531a.ada | 182 ++++ gcc/testsuite/ada/acats/tests/c4/c45531b.ada | 153 +++ gcc/testsuite/ada/acats/tests/c4/c45531c.ada | 183 ++++ gcc/testsuite/ada/acats/tests/c4/c45531d.ada | 153 +++ gcc/testsuite/ada/acats/tests/c4/c45531e.ada | 182 ++++ gcc/testsuite/ada/acats/tests/c4/c45531f.ada | 153 +++ gcc/testsuite/ada/acats/tests/c4/c45531g.ada | 183 ++++ gcc/testsuite/ada/acats/tests/c4/c45531h.ada | 153 +++ gcc/testsuite/ada/acats/tests/c4/c45531i.ada | 182 ++++ gcc/testsuite/ada/acats/tests/c4/c45531j.ada | 153 +++ gcc/testsuite/ada/acats/tests/c4/c45531k.ada | 184 ++++ gcc/testsuite/ada/acats/tests/c4/c45531l.ada | 154 +++ gcc/testsuite/ada/acats/tests/c4/c45531m.dep | 189 ++++ gcc/testsuite/ada/acats/tests/c4/c45531n.dep | 160 ++++ gcc/testsuite/ada/acats/tests/c4/c45531o.dep | 189 ++++ gcc/testsuite/ada/acats/tests/c4/c45531p.dep | 159 ++++ gcc/testsuite/ada/acats/tests/c4/c45532a.ada | 152 +++ gcc/testsuite/ada/acats/tests/c4/c45532b.ada | 159 ++++ gcc/testsuite/ada/acats/tests/c4/c45532c.ada | 156 +++ gcc/testsuite/ada/acats/tests/c4/c45532d.ada | 150 +++ gcc/testsuite/ada/acats/tests/c4/c45532e.ada | 151 +++ gcc/testsuite/ada/acats/tests/c4/c45532f.ada | 158 ++++ gcc/testsuite/ada/acats/tests/c4/c45532g.ada | 155 +++ gcc/testsuite/ada/acats/tests/c4/c45532h.ada | 149 +++ gcc/testsuite/ada/acats/tests/c4/c45532i.ada | 152 +++ gcc/testsuite/ada/acats/tests/c4/c45532j.ada | 158 ++++ gcc/testsuite/ada/acats/tests/c4/c45532k.ada | 156 +++ gcc/testsuite/ada/acats/tests/c4/c45532l.ada | 150 +++ gcc/testsuite/ada/acats/tests/c4/c45532m.dep | 157 ++++ gcc/testsuite/ada/acats/tests/c4/c45532n.dep | 163 ++++ gcc/testsuite/ada/acats/tests/c4/c45532o.dep | 161 ++++ gcc/testsuite/ada/acats/tests/c4/c45532p.dep | 155 +++ gcc/testsuite/ada/acats/tests/c4/c45534b.ada | 105 +++ gcc/testsuite/ada/acats/tests/c4/c45536a.dep | 158 ++++ gcc/testsuite/ada/acats/tests/c4/c456001.a | 91 ++ gcc/testsuite/ada/acats/tests/c4/c45611a.ada | 123 +++ gcc/testsuite/ada/acats/tests/c4/c45611b.dep | 141 +++ gcc/testsuite/ada/acats/tests/c4/c45611c.dep | 141 +++ gcc/testsuite/ada/acats/tests/c4/c45613a.ada | 79 ++ gcc/testsuite/ada/acats/tests/c4/c45613b.dep | 97 ++ gcc/testsuite/ada/acats/tests/c4/c45613c.dep | 97 ++ gcc/testsuite/ada/acats/tests/c4/c45614a.ada | 99 ++ gcc/testsuite/ada/acats/tests/c4/c45614b.dep | 128 +++ gcc/testsuite/ada/acats/tests/c4/c45614c.dep | 125 +++ gcc/testsuite/ada/acats/tests/c4/c45622a.ada | 83 ++ gcc/testsuite/ada/acats/tests/c4/c45624a.ada | 86 ++ gcc/testsuite/ada/acats/tests/c4/c45624b.ada | 81 ++ gcc/testsuite/ada/acats/tests/c4/c45631a.ada | 98 ++ gcc/testsuite/ada/acats/tests/c4/c45631b.dep | 116 +++ gcc/testsuite/ada/acats/tests/c4/c45631c.dep | 122 +++ gcc/testsuite/ada/acats/tests/c4/c45632a.ada | 76 ++ gcc/testsuite/ada/acats/tests/c4/c45632b.dep | 94 ++ gcc/testsuite/ada/acats/tests/c4/c45632c.dep | 94 ++ gcc/testsuite/ada/acats/tests/c4/c45651a.ada | 246 +++++ gcc/testsuite/ada/acats/tests/c4/c45662a.ada | 105 +++ gcc/testsuite/ada/acats/tests/c4/c45662b.ada | 120 +++ gcc/testsuite/ada/acats/tests/c4/c45672a.ada | 109 +++ gcc/testsuite/ada/acats/tests/c4/c460001.a | 300 ++++++ gcc/testsuite/ada/acats/tests/c4/c460002.a | 330 +++++++ gcc/testsuite/ada/acats/tests/c4/c460004.a | 335 +++++++ gcc/testsuite/ada/acats/tests/c4/c460005.a | 260 +++++ gcc/testsuite/ada/acats/tests/c4/c460006.a | 378 ++++++++ gcc/testsuite/ada/acats/tests/c4/c460007.a | 239 +++++ gcc/testsuite/ada/acats/tests/c4/c460008.a | 286 ++++++ gcc/testsuite/ada/acats/tests/c4/c460009.a | 467 +++++++++ gcc/testsuite/ada/acats/tests/c4/c460010.a | 354 +++++++ gcc/testsuite/ada/acats/tests/c4/c460011.a | 210 +++++ gcc/testsuite/ada/acats/tests/c4/c460012.a | 93 ++ gcc/testsuite/ada/acats/tests/c4/c46011a.ada | 145 +++ gcc/testsuite/ada/acats/tests/c4/c46013a.ada | 260 +++++ gcc/testsuite/ada/acats/tests/c4/c46014a.ada | 287 ++++++ gcc/testsuite/ada/acats/tests/c4/c46021a.ada | 210 +++++ gcc/testsuite/ada/acats/tests/c4/c46024a.ada | 136 +++ gcc/testsuite/ada/acats/tests/c4/c46031a.ada | 85 ++ gcc/testsuite/ada/acats/tests/c4/c46032a.ada | 103 ++ gcc/testsuite/ada/acats/tests/c4/c46033a.ada | 110 +++ gcc/testsuite/ada/acats/tests/c4/c46041a.ada | 141 +++ gcc/testsuite/ada/acats/tests/c4/c46042a.ada | 146 +++ gcc/testsuite/ada/acats/tests/c4/c46043b.ada | 148 +++ gcc/testsuite/ada/acats/tests/c4/c46044b.ada | 235 +++++ gcc/testsuite/ada/acats/tests/c4/c46051a.ada | 414 ++++++++ gcc/testsuite/ada/acats/tests/c4/c46051b.ada | 102 ++ gcc/testsuite/ada/acats/tests/c4/c46051c.ada | 120 +++ gcc/testsuite/ada/acats/tests/c4/c46052a.ada | 100 ++ gcc/testsuite/ada/acats/tests/c4/c46053a.ada | 139 +++ gcc/testsuite/ada/acats/tests/c4/c46054a.ada | 191 ++++ gcc/testsuite/ada/acats/tests/c4/c460a01.a | 408 ++++++++ gcc/testsuite/ada/acats/tests/c4/c460a02.a | 413 ++++++++ gcc/testsuite/ada/acats/tests/c4/c47002a.ada | 107 +++ gcc/testsuite/ada/acats/tests/c4/c47002b.ada | 115 +++ gcc/testsuite/ada/acats/tests/c4/c47002c.ada | 212 +++++ gcc/testsuite/ada/acats/tests/c4/c47002d.ada | 273 ++++++ gcc/testsuite/ada/acats/tests/c4/c47003a.ada | 115 +++ gcc/testsuite/ada/acats/tests/c4/c47004a.ada | 115 +++ gcc/testsuite/ada/acats/tests/c4/c47005a.ada | 136 +++ gcc/testsuite/ada/acats/tests/c4/c47006a.ada | 100 ++ gcc/testsuite/ada/acats/tests/c4/c47007a.ada | 195 ++++ gcc/testsuite/ada/acats/tests/c4/c47008a.ada | 299 ++++++ gcc/testsuite/ada/acats/tests/c4/c47009a.ada | 254 +++++ gcc/testsuite/ada/acats/tests/c4/c47009b.ada | 282 ++++++ gcc/testsuite/ada/acats/tests/c4/c48004a.ada | 60 ++ gcc/testsuite/ada/acats/tests/c4/c48004b.ada | 140 +++ gcc/testsuite/ada/acats/tests/c4/c48004c.ada | 101 ++ gcc/testsuite/ada/acats/tests/c4/c48004d.ada | 124 +++ gcc/testsuite/ada/acats/tests/c4/c48004e.ada | 89 ++ gcc/testsuite/ada/acats/tests/c4/c48004f.ada | 99 ++ gcc/testsuite/ada/acats/tests/c4/c48005a.ada | 121 +++ gcc/testsuite/ada/acats/tests/c4/c48005b.ada | 78 ++ gcc/testsuite/ada/acats/tests/c4/c48006a.ada | 96 ++ gcc/testsuite/ada/acats/tests/c4/c48006b.ada | 236 +++++ gcc/testsuite/ada/acats/tests/c4/c48007a.ada | 130 +++ gcc/testsuite/ada/acats/tests/c4/c48007b.ada | 133 +++ gcc/testsuite/ada/acats/tests/c4/c48007c.ada | 162 ++++ gcc/testsuite/ada/acats/tests/c4/c48008a.ada | 345 +++++++ gcc/testsuite/ada/acats/tests/c4/c48008c.ada | 79 ++ gcc/testsuite/ada/acats/tests/c4/c48009a.ada | 104 ++ gcc/testsuite/ada/acats/tests/c4/c48009b.ada | 255 +++++ gcc/testsuite/ada/acats/tests/c4/c48009c.ada | 113 +++ gcc/testsuite/ada/acats/tests/c4/c48009d.ada | 128 +++ gcc/testsuite/ada/acats/tests/c4/c48009e.ada | 224 +++++ gcc/testsuite/ada/acats/tests/c4/c48009f.ada | 99 ++ gcc/testsuite/ada/acats/tests/c4/c48009g.ada | 209 +++++ gcc/testsuite/ada/acats/tests/c4/c48009h.ada | 129 +++ gcc/testsuite/ada/acats/tests/c4/c48009i.ada | 128 +++ gcc/testsuite/ada/acats/tests/c4/c48009j.ada | 132 +++ gcc/testsuite/ada/acats/tests/c4/c48010a.ada | 90 ++ gcc/testsuite/ada/acats/tests/c4/c48011a.ada | 101 ++ gcc/testsuite/ada/acats/tests/c4/c48012a.ada | 75 ++ gcc/testsuite/ada/acats/tests/c4/c490001.a | 215 +++++ gcc/testsuite/ada/acats/tests/c4/c490002.a | 239 +++++ gcc/testsuite/ada/acats/tests/c4/c490003.a | 215 +++++ gcc/testsuite/ada/acats/tests/c4/c49020a.ada | 73 ++ gcc/testsuite/ada/acats/tests/c4/c49021a.ada | 83 ++ gcc/testsuite/ada/acats/tests/c4/c49022a.ada | 158 ++++ gcc/testsuite/ada/acats/tests/c4/c49022b.ada | 73 ++ gcc/testsuite/ada/acats/tests/c4/c49022c.ada | 170 ++++ gcc/testsuite/ada/acats/tests/c4/c49023a.ada | 117 +++ gcc/testsuite/ada/acats/tests/c4/c49024a.ada | 134 +++ gcc/testsuite/ada/acats/tests/c4/c49025a.ada | 104 ++ gcc/testsuite/ada/acats/tests/c4/c49026a.ada | 59 ++ gcc/testsuite/ada/acats/tests/c4/c4a005b.ada | 104 ++ gcc/testsuite/ada/acats/tests/c4/c4a006a.ada | 61 ++ gcc/testsuite/ada/acats/tests/c4/c4a007a.tst | 47 + gcc/testsuite/ada/acats/tests/c4/c4a010a.ada | 80 ++ gcc/testsuite/ada/acats/tests/c4/c4a010b.ada | 82 ++ gcc/testsuite/ada/acats/tests/c4/c4a011a.ada | 334 +++++++ gcc/testsuite/ada/acats/tests/c4/c4a012b.ada | 184 ++++ gcc/testsuite/ada/acats/tests/c4/c4a013a.ada | 77 ++ gcc/testsuite/ada/acats/tests/c4/c4a014a.ada | 86 ++ gcc/testsuite/ada/acats/tests/c5/c51004a.ada | 261 ++++++ gcc/testsuite/ada/acats/tests/c5/c52005a.ada | 177 ++++ gcc/testsuite/ada/acats/tests/c5/c52005b.ada | 115 +++ gcc/testsuite/ada/acats/tests/c5/c52005c.ada | 79 ++ gcc/testsuite/ada/acats/tests/c5/c52005d.ada | 182 ++++ gcc/testsuite/ada/acats/tests/c5/c52005e.ada | 129 +++ gcc/testsuite/ada/acats/tests/c5/c52005f.ada | 86 ++ gcc/testsuite/ada/acats/tests/c5/c52008a.ada | 73 ++ gcc/testsuite/ada/acats/tests/c5/c52008b.ada | 110 +++ gcc/testsuite/ada/acats/tests/c5/c52009a.ada | 77 ++ gcc/testsuite/ada/acats/tests/c5/c52009b.ada | 81 ++ gcc/testsuite/ada/acats/tests/c5/c52010a.ada | 186 ++++ gcc/testsuite/ada/acats/tests/c5/c52011a.ada | 170 ++++ gcc/testsuite/ada/acats/tests/c5/c52011b.ada | 180 ++++ gcc/testsuite/ada/acats/tests/c5/c52101a.ada | 81 ++ gcc/testsuite/ada/acats/tests/c5/c52102a.ada | 251 +++++ gcc/testsuite/ada/acats/tests/c5/c52102b.ada | 278 ++++++ gcc/testsuite/ada/acats/tests/c5/c52102c.ada | 280 ++++++ gcc/testsuite/ada/acats/tests/c5/c52102d.ada | 307 ++++++ gcc/testsuite/ada/acats/tests/c5/c52103a.ada | 385 ++++++++ gcc/testsuite/ada/acats/tests/c5/c52103b.ada | 139 +++ gcc/testsuite/ada/acats/tests/c5/c52103c.ada | 178 ++++ gcc/testsuite/ada/acats/tests/c5/c52103f.ada | 338 +++++++ gcc/testsuite/ada/acats/tests/c5/c52103g.ada | 142 +++ gcc/testsuite/ada/acats/tests/c5/c52103h.ada | 175 ++++ gcc/testsuite/ada/acats/tests/c5/c52103k.ada | 393 ++++++++ gcc/testsuite/ada/acats/tests/c5/c52103l.ada | 145 +++ gcc/testsuite/ada/acats/tests/c5/c52103m.ada | 183 ++++ gcc/testsuite/ada/acats/tests/c5/c52103p.ada | 344 +++++++ gcc/testsuite/ada/acats/tests/c5/c52103q.ada | 143 +++ gcc/testsuite/ada/acats/tests/c5/c52103r.ada | 181 ++++ gcc/testsuite/ada/acats/tests/c5/c52103x.ada | 241 +++++ gcc/testsuite/ada/acats/tests/c5/c52104a.ada | 343 +++++++ gcc/testsuite/ada/acats/tests/c5/c52104b.ada | 144 +++ gcc/testsuite/ada/acats/tests/c5/c52104c.ada | 178 ++++ gcc/testsuite/ada/acats/tests/c5/c52104f.ada | 292 ++++++ gcc/testsuite/ada/acats/tests/c5/c52104g.ada | 146 +++ gcc/testsuite/ada/acats/tests/c5/c52104h.ada | 183 ++++ gcc/testsuite/ada/acats/tests/c5/c52104k.ada | 347 +++++++ gcc/testsuite/ada/acats/tests/c5/c52104l.ada | 146 +++ gcc/testsuite/ada/acats/tests/c5/c52104m.ada | 184 ++++ gcc/testsuite/ada/acats/tests/c5/c52104p.ada | 292 ++++++ gcc/testsuite/ada/acats/tests/c5/c52104q.ada | 146 +++ gcc/testsuite/ada/acats/tests/c5/c52104r.ada | 190 ++++ gcc/testsuite/ada/acats/tests/c5/c52104x.ada | 222 +++++ gcc/testsuite/ada/acats/tests/c5/c52104y.ada | 174 ++++ gcc/testsuite/ada/acats/tests/c5/c53007a.ada | 139 +++ gcc/testsuite/ada/acats/tests/c5/c540001.a | 410 ++++++++ gcc/testsuite/ada/acats/tests/c5/c54a03a.ada | 105 +++ gcc/testsuite/ada/acats/tests/c5/c54a04a.ada | 75 ++ gcc/testsuite/ada/acats/tests/c5/c54a07a.ada | 111 +++ gcc/testsuite/ada/acats/tests/c5/c54a13a.ada | 109 +++ gcc/testsuite/ada/acats/tests/c5/c54a13b.ada | 105 +++ gcc/testsuite/ada/acats/tests/c5/c54a13c.ada | 104 ++ gcc/testsuite/ada/acats/tests/c5/c54a13d.ada | 138 +++ gcc/testsuite/ada/acats/tests/c5/c54a22a.ada | 68 ++ gcc/testsuite/ada/acats/tests/c5/c54a23a.ada | 49 + gcc/testsuite/ada/acats/tests/c5/c54a24a.ada | 63 ++ gcc/testsuite/ada/acats/tests/c5/c54a24b.ada | 58 ++ gcc/testsuite/ada/acats/tests/c5/c54a42a.ada | 173 ++++ gcc/testsuite/ada/acats/tests/c5/c54a42b.ada | 173 ++++ gcc/testsuite/ada/acats/tests/c5/c54a42c.ada | 123 +++ gcc/testsuite/ada/acats/tests/c5/c54a42d.ada | 104 ++ gcc/testsuite/ada/acats/tests/c5/c54a42e.ada | 125 +++ gcc/testsuite/ada/acats/tests/c5/c54a42f.ada | 126 +++ gcc/testsuite/ada/acats/tests/c5/c54a42g.ada | 119 +++ gcc/testsuite/ada/acats/tests/c5/c55b03a.ada | 59 ++ gcc/testsuite/ada/acats/tests/c5/c55b04a.ada | 96 ++ gcc/testsuite/ada/acats/tests/c5/c55b05a.ada | 170 ++++ gcc/testsuite/ada/acats/tests/c5/c55b06a.ada | 313 +++++++ gcc/testsuite/ada/acats/tests/c5/c55b06b.ada | 188 ++++ gcc/testsuite/ada/acats/tests/c5/c55b07a.dep | 126 +++ gcc/testsuite/ada/acats/tests/c5/c55b07b.dep | 126 +++ gcc/testsuite/ada/acats/tests/c5/c55b10a.ada | 80 ++ gcc/testsuite/ada/acats/tests/c5/c55b11a.ada | 104 ++ gcc/testsuite/ada/acats/tests/c5/c55b11b.ada | 86 ++ gcc/testsuite/ada/acats/tests/c5/c55b15a.ada | 207 ++++ gcc/testsuite/ada/acats/tests/c5/c55b16a.ada | 101 ++ gcc/testsuite/ada/acats/tests/c5/c55c02a.ada | 49 + gcc/testsuite/ada/acats/tests/c5/c55c02b.ada | 59 ++ gcc/testsuite/ada/acats/tests/c5/c56002a.ada | 148 +++ gcc/testsuite/ada/acats/tests/c5/c57003a.ada | 334 +++++++ gcc/testsuite/ada/acats/tests/c5/c57004a.ada | 160 ++++ gcc/testsuite/ada/acats/tests/c5/c57004b.ada | 162 ++++ gcc/testsuite/ada/acats/tests/c5/c58004c.ada | 86 ++ gcc/testsuite/ada/acats/tests/c5/c58004d.ada | 90 ++ gcc/testsuite/ada/acats/tests/c5/c58004g.ada | 95 ++ gcc/testsuite/ada/acats/tests/c5/c58005a.ada | 121 +++ gcc/testsuite/ada/acats/tests/c5/c58005b.ada | 94 ++ gcc/testsuite/ada/acats/tests/c5/c58005h.ada | 172 ++++ gcc/testsuite/ada/acats/tests/c5/c58006a.ada | 128 +++ gcc/testsuite/ada/acats/tests/c5/c58006b.ada | 141 +++ gcc/testsuite/ada/acats/tests/c5/c59002a.ada | 102 ++ gcc/testsuite/ada/acats/tests/c5/c59002b.ada | 209 +++++ gcc/testsuite/ada/acats/tests/c5/c59002c.ada | 150 +++ gcc/testsuite/ada/acats/tests/c6/c61008a.ada | 266 ++++++ gcc/testsuite/ada/acats/tests/c6/c61009a.ada | 160 ++++ gcc/testsuite/ada/acats/tests/c6/c61010a.ada | 246 +++++ gcc/testsuite/ada/acats/tests/c6/c62002a.ada | 190 ++++ gcc/testsuite/ada/acats/tests/c6/c62003a.ada | 234 +++++ gcc/testsuite/ada/acats/tests/c6/c62003b.ada | 301 ++++++ gcc/testsuite/ada/acats/tests/c6/c62004a.ada | 64 ++ gcc/testsuite/ada/acats/tests/c6/c62006a.ada | 70 ++ gcc/testsuite/ada/acats/tests/c6/c631001.a | 134 +++ gcc/testsuite/ada/acats/tests/c6/c640001.a | 334 +++++++ gcc/testsuite/ada/acats/tests/c6/c64002b.ada | 65 ++ gcc/testsuite/ada/acats/tests/c6/c64004g.ada | 102 ++ gcc/testsuite/ada/acats/tests/c6/c64005a.ada | 64 ++ gcc/testsuite/ada/acats/tests/c6/c64005b.ada | 109 +++ gcc/testsuite/ada/acats/tests/c6/c64005c.ada | 330 +++++++ gcc/testsuite/ada/acats/tests/c6/c64005d0.ada | 219 +++++ gcc/testsuite/ada/acats/tests/c6/c64005da.ada | 65 ++ gcc/testsuite/ada/acats/tests/c6/c64005db.ada | 67 ++ gcc/testsuite/ada/acats/tests/c6/c64005dc.ada | 74 ++ gcc/testsuite/ada/acats/tests/c6/c641001.a | 281 ++++++ gcc/testsuite/ada/acats/tests/c6/c64103b.ada | 379 ++++++++ gcc/testsuite/ada/acats/tests/c6/c64103c.ada | 230 +++++ gcc/testsuite/ada/acats/tests/c6/c64103d.ada | 187 ++++ gcc/testsuite/ada/acats/tests/c6/c64103e.ada | 219 +++++ gcc/testsuite/ada/acats/tests/c6/c64103f.ada | 144 +++ gcc/testsuite/ada/acats/tests/c6/c64104a.ada | 215 +++++ gcc/testsuite/ada/acats/tests/c6/c64104b.ada | 136 +++ gcc/testsuite/ada/acats/tests/c6/c64104c.ada | 200 ++++ gcc/testsuite/ada/acats/tests/c6/c64104d.ada | 93 ++ gcc/testsuite/ada/acats/tests/c6/c64104e.ada | 82 ++ gcc/testsuite/ada/acats/tests/c6/c64104f.ada | 79 ++ gcc/testsuite/ada/acats/tests/c6/c64104g.ada | 93 ++ gcc/testsuite/ada/acats/tests/c6/c64104h.ada | 111 +++ gcc/testsuite/ada/acats/tests/c6/c64104i.ada | 101 ++ gcc/testsuite/ada/acats/tests/c6/c64104j.ada | 88 ++ gcc/testsuite/ada/acats/tests/c6/c64104k.ada | 95 ++ gcc/testsuite/ada/acats/tests/c6/c64104l.ada | 109 +++ gcc/testsuite/ada/acats/tests/c6/c64104m.ada | 95 ++ gcc/testsuite/ada/acats/tests/c6/c64104n.ada | 116 +++ gcc/testsuite/ada/acats/tests/c6/c64104o.ada | 112 +++ gcc/testsuite/ada/acats/tests/c6/c64105a.ada | 84 ++ gcc/testsuite/ada/acats/tests/c6/c64105b.ada | 184 ++++ gcc/testsuite/ada/acats/tests/c6/c64105c.ada | 230 +++++ gcc/testsuite/ada/acats/tests/c6/c64105d.ada | 134 +++ gcc/testsuite/ada/acats/tests/c6/c64106a.ada | 351 +++++++ gcc/testsuite/ada/acats/tests/c6/c64106b.ada | 237 +++++ gcc/testsuite/ada/acats/tests/c6/c64106c.ada | 309 ++++++ gcc/testsuite/ada/acats/tests/c6/c64106d.ada | 280 ++++++ gcc/testsuite/ada/acats/tests/c6/c64107a.ada | 73 ++ gcc/testsuite/ada/acats/tests/c6/c64108a.ada | 148 +++ gcc/testsuite/ada/acats/tests/c6/c64109a.ada | 128 +++ gcc/testsuite/ada/acats/tests/c6/c64109b.ada | 155 +++ gcc/testsuite/ada/acats/tests/c6/c64109c.ada | 127 +++ gcc/testsuite/ada/acats/tests/c6/c64109d.ada | 128 +++ gcc/testsuite/ada/acats/tests/c6/c64109e.ada | 156 +++ gcc/testsuite/ada/acats/tests/c6/c64109f.ada | 126 +++ gcc/testsuite/ada/acats/tests/c6/c64109g.ada | 125 +++ gcc/testsuite/ada/acats/tests/c6/c64109h.ada | 160 ++++ gcc/testsuite/ada/acats/tests/c6/c64109i.ada | 163 ++++ gcc/testsuite/ada/acats/tests/c6/c64109j.ada | 164 ++++ gcc/testsuite/ada/acats/tests/c6/c64109k.ada | 191 ++++ gcc/testsuite/ada/acats/tests/c6/c64109l.ada | 158 ++++ gcc/testsuite/ada/acats/tests/c6/c64201b.ada | 101 ++ gcc/testsuite/ada/acats/tests/c6/c64201c.ada | 196 ++++ gcc/testsuite/ada/acats/tests/c6/c64202a.ada | 72 ++ gcc/testsuite/ada/acats/tests/c6/c650001.a | 412 ++++++++ gcc/testsuite/ada/acats/tests/c6/c65003a.ada | 100 ++ gcc/testsuite/ada/acats/tests/c6/c65003b.ada | 73 ++ gcc/testsuite/ada/acats/tests/c6/c66002a.ada | 104 ++ gcc/testsuite/ada/acats/tests/c6/c66002c.ada | 102 ++ gcc/testsuite/ada/acats/tests/c6/c66002d.ada | 85 ++ gcc/testsuite/ada/acats/tests/c6/c66002e.ada | 91 ++ gcc/testsuite/ada/acats/tests/c6/c66002f.ada | 92 ++ gcc/testsuite/ada/acats/tests/c6/c66002g.ada | 82 ++ gcc/testsuite/ada/acats/tests/c6/c67002a.ada | 426 +++++++++ gcc/testsuite/ada/acats/tests/c6/c67002b.ada | 176 ++++ gcc/testsuite/ada/acats/tests/c6/c67002c.ada | 548 +++++++++++ gcc/testsuite/ada/acats/tests/c6/c67002d.ada | 354 +++++++ gcc/testsuite/ada/acats/tests/c6/c67002e.ada | 348 +++++++ gcc/testsuite/ada/acats/tests/c6/c67003f.ada | 319 +++++++ gcc/testsuite/ada/acats/tests/c6/c67005a.ada | 96 ++ gcc/testsuite/ada/acats/tests/c6/c67005b.ada | 124 +++ gcc/testsuite/ada/acats/tests/c6/c67005c.ada | 109 +++ gcc/testsuite/ada/acats/tests/c6/c67005d.ada | 78 ++ gcc/testsuite/ada/acats/tests/c7/c72001b.ada | 96 ++ gcc/testsuite/ada/acats/tests/c7/c72002a.ada | 229 +++++ gcc/testsuite/ada/acats/tests/c7/c730001.a | 437 +++++++++ gcc/testsuite/ada/acats/tests/c7/c730002.a | 383 ++++++++ gcc/testsuite/ada/acats/tests/c7/c730003.a | 283 ++++++ gcc/testsuite/ada/acats/tests/c7/c730004.a | 327 +++++++ gcc/testsuite/ada/acats/tests/c7/c73002a.ada | 110 +++ gcc/testsuite/ada/acats/tests/c7/c730a01.a | 176 ++++ gcc/testsuite/ada/acats/tests/c7/c730a02.a | 252 +++++ gcc/testsuite/ada/acats/tests/c7/c731001.a | 407 ++++++++ gcc/testsuite/ada/acats/tests/c7/c74004a.ada | 375 ++++++++ gcc/testsuite/ada/acats/tests/c7/c74203a.ada | 263 ++++++ gcc/testsuite/ada/acats/tests/c7/c74206a.ada | 144 +++ gcc/testsuite/ada/acats/tests/c7/c74207b.ada | 75 ++ gcc/testsuite/ada/acats/tests/c7/c74208a.ada | 116 +++ gcc/testsuite/ada/acats/tests/c7/c74208b.ada | 106 +++ gcc/testsuite/ada/acats/tests/c7/c74209a.ada | 224 +++++ gcc/testsuite/ada/acats/tests/c7/c74210a.ada | 117 +++ gcc/testsuite/ada/acats/tests/c7/c74211a.ada | 195 ++++ gcc/testsuite/ada/acats/tests/c7/c74211b.ada | 156 +++ gcc/testsuite/ada/acats/tests/c7/c74302a.ada | 81 ++ gcc/testsuite/ada/acats/tests/c7/c74302b.ada | 308 ++++++ gcc/testsuite/ada/acats/tests/c7/c74305a.ada | 160 ++++ gcc/testsuite/ada/acats/tests/c7/c74305b.ada | 101 ++ gcc/testsuite/ada/acats/tests/c7/c74306a.ada | 279 ++++++ gcc/testsuite/ada/acats/tests/c7/c74307a.ada | 58 ++ gcc/testsuite/ada/acats/tests/c7/c74401d.ada | 111 +++ gcc/testsuite/ada/acats/tests/c7/c74401e.ada | 120 +++ gcc/testsuite/ada/acats/tests/c7/c74401k.ada | 136 +++ gcc/testsuite/ada/acats/tests/c7/c74401q.ada | 119 +++ gcc/testsuite/ada/acats/tests/c7/c74402a.ada | 154 +++ gcc/testsuite/ada/acats/tests/c7/c74402b.ada | 103 ++ gcc/testsuite/ada/acats/tests/c7/c74406a.ada | 130 +++ gcc/testsuite/ada/acats/tests/c7/c74407b.ada | 195 ++++ gcc/testsuite/ada/acats/tests/c7/c74409b.ada | 93 ++ gcc/testsuite/ada/acats/tests/c7/c760001.a | 390 ++++++++ gcc/testsuite/ada/acats/tests/c7/c760002.a | 489 ++++++++++ gcc/testsuite/ada/acats/tests/c7/c760007.a | 247 +++++ gcc/testsuite/ada/acats/tests/c7/c760009.a | 533 +++++++++++ gcc/testsuite/ada/acats/tests/c7/c760010.a | 418 +++++++++ gcc/testsuite/ada/acats/tests/c7/c760011.a | 291 ++++++ gcc/testsuite/ada/acats/tests/c7/c760012.a | 256 +++++ gcc/testsuite/ada/acats/tests/c7/c760013.a | 108 +++ gcc/testsuite/ada/acats/tests/c7/c761001.a | 117 +++ gcc/testsuite/ada/acats/tests/c7/c761002.a | 245 +++++ gcc/testsuite/ada/acats/tests/c7/c761003.a | 447 +++++++++ gcc/testsuite/ada/acats/tests/c7/c761004.a | 305 ++++++ gcc/testsuite/ada/acats/tests/c7/c761005.a | 288 ++++++ gcc/testsuite/ada/acats/tests/c7/c761006.a | 425 +++++++++ gcc/testsuite/ada/acats/tests/c7/c761007.a | 419 +++++++++ gcc/testsuite/ada/acats/tests/c7/c761010.a | 447 +++++++++ gcc/testsuite/ada/acats/tests/c7/c761011.a | 410 ++++++++ gcc/testsuite/ada/acats/tests/c7/c761012.a | 151 +++ gcc/testsuite/ada/acats/tests/c8/c83007a.ada | 95 ++ gcc/testsuite/ada/acats/tests/c8/c83012d.ada | 116 +++ gcc/testsuite/ada/acats/tests/c8/c83022a.ada | 338 +++++++ gcc/testsuite/ada/acats/tests/c8/c83022g0.ada | 165 ++++ gcc/testsuite/ada/acats/tests/c8/c83022g1.ada | 189 ++++ gcc/testsuite/ada/acats/tests/c8/c83023a.ada | 194 ++++ gcc/testsuite/ada/acats/tests/c8/c83024a.ada | 185 ++++ gcc/testsuite/ada/acats/tests/c8/c83024e0.ada | 112 +++ gcc/testsuite/ada/acats/tests/c8/c83024e1.ada | 220 +++++ gcc/testsuite/ada/acats/tests/c8/c83025a.ada | 283 ++++++ gcc/testsuite/ada/acats/tests/c8/c83025c.ada | 345 +++++++ gcc/testsuite/ada/acats/tests/c8/c83027a.ada | 188 ++++ gcc/testsuite/ada/acats/tests/c8/c83027c.ada | 157 ++++ gcc/testsuite/ada/acats/tests/c8/c83028a.ada | 156 +++ gcc/testsuite/ada/acats/tests/c8/c83029a.ada | 110 +++ gcc/testsuite/ada/acats/tests/c8/c83030a.ada | 234 +++++ gcc/testsuite/ada/acats/tests/c8/c83030c.ada | 263 ++++++ gcc/testsuite/ada/acats/tests/c8/c83031a.ada | 163 ++++ gcc/testsuite/ada/acats/tests/c8/c83031c.ada | 101 ++ gcc/testsuite/ada/acats/tests/c8/c83031e.ada | 70 ++ gcc/testsuite/ada/acats/tests/c8/c83032a.ada | 111 +++ gcc/testsuite/ada/acats/tests/c8/c83033a.ada | 146 +++ gcc/testsuite/ada/acats/tests/c8/c83051a.ada | 397 ++++++++ gcc/testsuite/ada/acats/tests/c8/c83b02a.ada | 79 ++ gcc/testsuite/ada/acats/tests/c8/c83b02b.ada | 112 +++ gcc/testsuite/ada/acats/tests/c8/c83e02a.ada | 84 ++ gcc/testsuite/ada/acats/tests/c8/c83e02b.ada | 65 ++ gcc/testsuite/ada/acats/tests/c8/c83e03a.ada | 81 ++ gcc/testsuite/ada/acats/tests/c8/c83f01a.ada | 109 +++ gcc/testsuite/ada/acats/tests/c8/c83f01b.ada | 129 +++ gcc/testsuite/ada/acats/tests/c8/c83f01c0.ada | 55 ++ gcc/testsuite/ada/acats/tests/c8/c83f01c1.ada | 69 ++ gcc/testsuite/ada/acats/tests/c8/c83f01c2.ada | 69 ++ gcc/testsuite/ada/acats/tests/c8/c83f01d0.ada | 103 ++ gcc/testsuite/ada/acats/tests/c8/c83f01d1.ada | 57 ++ gcc/testsuite/ada/acats/tests/c8/c83f03a.ada | 113 +++ gcc/testsuite/ada/acats/tests/c8/c83f03b.ada | 157 ++++ gcc/testsuite/ada/acats/tests/c8/c83f03c0.ada | 53 ++ gcc/testsuite/ada/acats/tests/c8/c83f03c1.ada | 81 ++ gcc/testsuite/ada/acats/tests/c8/c83f03c2.ada | 64 ++ gcc/testsuite/ada/acats/tests/c8/c83f03d0.ada | 89 ++ gcc/testsuite/ada/acats/tests/c8/c83f03d1.ada | 82 ++ gcc/testsuite/ada/acats/tests/c8/c840001.a | 257 +++++ gcc/testsuite/ada/acats/tests/c8/c84002a.ada | 267 ++++++ gcc/testsuite/ada/acats/tests/c8/c84005a.ada | 117 +++ gcc/testsuite/ada/acats/tests/c8/c84008a.ada | 83 ++ gcc/testsuite/ada/acats/tests/c8/c84009a.ada | 99 ++ gcc/testsuite/ada/acats/tests/c8/c85004b.ada | 164 ++++ gcc/testsuite/ada/acats/tests/c8/c85005a.ada | 391 ++++++++ gcc/testsuite/ada/acats/tests/c8/c85005b.ada | 366 ++++++++ gcc/testsuite/ada/acats/tests/c8/c85005c.ada | 416 ++++++++ gcc/testsuite/ada/acats/tests/c8/c85005d.ada | 378 ++++++++ gcc/testsuite/ada/acats/tests/c8/c85005e.ada | 397 ++++++++ gcc/testsuite/ada/acats/tests/c8/c85005f.ada | 71 ++ gcc/testsuite/ada/acats/tests/c8/c85005g.ada | 145 +++ gcc/testsuite/ada/acats/tests/c8/c85006a.ada | 681 ++++++++++++++ gcc/testsuite/ada/acats/tests/c8/c85006b.ada | 699 ++++++++++++++ gcc/testsuite/ada/acats/tests/c8/c85006c.ada | 778 +++++++++++++++ gcc/testsuite/ada/acats/tests/c8/c85006d.ada | 712 ++++++++++++++ gcc/testsuite/ada/acats/tests/c8/c85006e.ada | 702 ++++++++++++++ gcc/testsuite/ada/acats/tests/c8/c85006f.ada | 70 ++ gcc/testsuite/ada/acats/tests/c8/c85006g.ada | 136 +++ gcc/testsuite/ada/acats/tests/c8/c85007a.ada | 115 +++ gcc/testsuite/ada/acats/tests/c8/c85007e.ada | 102 ++ gcc/testsuite/ada/acats/tests/c8/c85009a.ada | 109 +++ gcc/testsuite/ada/acats/tests/c8/c85011a.ada | 145 +++ gcc/testsuite/ada/acats/tests/c8/c85013a.ada | 150 +++ gcc/testsuite/ada/acats/tests/c8/c85014a.ada | 142 +++ gcc/testsuite/ada/acats/tests/c8/c85014b.ada | 192 ++++ gcc/testsuite/ada/acats/tests/c8/c85014c.ada | 118 +++ gcc/testsuite/ada/acats/tests/c8/c85017a.ada | 61 ++ gcc/testsuite/ada/acats/tests/c8/c85018a.ada | 140 +++ gcc/testsuite/ada/acats/tests/c8/c85018b.ada | 288 ++++++ gcc/testsuite/ada/acats/tests/c8/c85019a.ada | 59 ++ gcc/testsuite/ada/acats/tests/c8/c854001.a | 277 ++++++ gcc/testsuite/ada/acats/tests/c8/c854002.a | 185 ++++ gcc/testsuite/ada/acats/tests/c8/c854003.a | 64 ++ gcc/testsuite/ada/acats/tests/c8/c86003a.ada | 122 +++ gcc/testsuite/ada/acats/tests/c8/c86004a.ada | 100 ++ gcc/testsuite/ada/acats/tests/c8/c86004b0.ada | 44 + gcc/testsuite/ada/acats/tests/c8/c86004b1.ada | 53 ++ gcc/testsuite/ada/acats/tests/c8/c86004b2.ada | 46 + gcc/testsuite/ada/acats/tests/c8/c86004c0.ada | 60 ++ gcc/testsuite/ada/acats/tests/c8/c86004c1.ada | 50 + gcc/testsuite/ada/acats/tests/c8/c86004c2.ada | 45 + gcc/testsuite/ada/acats/tests/c8/c86006i.ada | 103 ++ gcc/testsuite/ada/acats/tests/c8/c86007a.ada | 79 ++ gcc/testsuite/ada/acats/tests/c8/c87a05a.ada | 108 +++ gcc/testsuite/ada/acats/tests/c8/c87a05b.ada | 107 +++ gcc/testsuite/ada/acats/tests/c8/c87b02a.ada | 124 +++ gcc/testsuite/ada/acats/tests/c8/c87b02b.ada | 124 +++ gcc/testsuite/ada/acats/tests/c8/c87b03a.ada | 61 ++ gcc/testsuite/ada/acats/tests/c8/c87b04a.ada | 79 ++ gcc/testsuite/ada/acats/tests/c8/c87b04b.ada | 82 ++ gcc/testsuite/ada/acats/tests/c8/c87b04c.ada | 60 ++ gcc/testsuite/ada/acats/tests/c8/c87b05a.ada | 70 ++ gcc/testsuite/ada/acats/tests/c8/c87b06a.ada | 90 ++ gcc/testsuite/ada/acats/tests/c8/c87b07a.ada | 64 ++ gcc/testsuite/ada/acats/tests/c8/c87b07b.ada | 101 ++ gcc/testsuite/ada/acats/tests/c8/c87b07c.ada | 85 ++ gcc/testsuite/ada/acats/tests/c8/c87b07d.ada | 59 ++ gcc/testsuite/ada/acats/tests/c8/c87b07e.ada | 69 ++ gcc/testsuite/ada/acats/tests/c8/c87b08a.ada | 72 ++ gcc/testsuite/ada/acats/tests/c8/c87b09a.ada | 55 ++ gcc/testsuite/ada/acats/tests/c8/c87b09c.ada | 64 ++ gcc/testsuite/ada/acats/tests/c8/c87b10a.ada | 75 ++ gcc/testsuite/ada/acats/tests/c8/c87b11a.ada | 55 ++ gcc/testsuite/ada/acats/tests/c8/c87b11b.ada | 57 ++ gcc/testsuite/ada/acats/tests/c8/c87b13a.ada | 71 ++ gcc/testsuite/ada/acats/tests/c8/c87b14a.ada | 87 ++ gcc/testsuite/ada/acats/tests/c8/c87b14b.ada | 90 ++ gcc/testsuite/ada/acats/tests/c8/c87b14c.ada | 89 ++ gcc/testsuite/ada/acats/tests/c8/c87b14d.ada | 63 ++ gcc/testsuite/ada/acats/tests/c8/c87b15a.ada | 108 +++ gcc/testsuite/ada/acats/tests/c8/c87b16a.ada | 129 +++ gcc/testsuite/ada/acats/tests/c8/c87b17a.ada | 130 +++ gcc/testsuite/ada/acats/tests/c8/c87b18a.ada | 82 ++ gcc/testsuite/ada/acats/tests/c8/c87b18b.ada | 83 ++ gcc/testsuite/ada/acats/tests/c8/c87b19a.ada | 110 +++ gcc/testsuite/ada/acats/tests/c8/c87b23a.ada | 100 ++ gcc/testsuite/ada/acats/tests/c8/c87b24a.ada | 79 ++ gcc/testsuite/ada/acats/tests/c8/c87b24b.ada | 98 ++ gcc/testsuite/ada/acats/tests/c8/c87b26b.ada | 149 +++ gcc/testsuite/ada/acats/tests/c8/c87b27a.ada | 80 ++ gcc/testsuite/ada/acats/tests/c8/c87b28a.ada | 71 ++ gcc/testsuite/ada/acats/tests/c8/c87b29a.ada | 72 ++ gcc/testsuite/ada/acats/tests/c8/c87b30a.ada | 84 ++ gcc/testsuite/ada/acats/tests/c8/c87b31a.ada | 137 +++ gcc/testsuite/ada/acats/tests/c8/c87b32a.ada | 199 ++++ gcc/testsuite/ada/acats/tests/c8/c87b33a.ada | 117 +++ gcc/testsuite/ada/acats/tests/c8/c87b34a.ada | 68 ++ gcc/testsuite/ada/acats/tests/c8/c87b34b.ada | 71 ++ gcc/testsuite/ada/acats/tests/c8/c87b34c.ada | 75 ++ gcc/testsuite/ada/acats/tests/c8/c87b35c.ada | 82 ++ gcc/testsuite/ada/acats/tests/c8/c87b38a.ada | 76 ++ gcc/testsuite/ada/acats/tests/c8/c87b39a.ada | 106 +++ gcc/testsuite/ada/acats/tests/c8/c87b40a.ada | 106 +++ gcc/testsuite/ada/acats/tests/c8/c87b41a.ada | 112 +++ gcc/testsuite/ada/acats/tests/c8/c87b42a.ada | 77 ++ gcc/testsuite/ada/acats/tests/c8/c87b43a.ada | 60 ++ gcc/testsuite/ada/acats/tests/c8/c87b44a.ada | 112 +++ gcc/testsuite/ada/acats/tests/c8/c87b45a.ada | 126 +++ gcc/testsuite/ada/acats/tests/c8/c87b45c.ada | 148 +++ gcc/testsuite/ada/acats/tests/c8/c87b47a.ada | 74 ++ gcc/testsuite/ada/acats/tests/c8/c87b48a.ada | 94 ++ gcc/testsuite/ada/acats/tests/c8/c87b48b.ada | 72 ++ gcc/testsuite/ada/acats/tests/c8/c87b50a.ada | 64 ++ gcc/testsuite/ada/acats/tests/c8/c87b54a.ada | 87 ++ gcc/testsuite/ada/acats/tests/c8/c87b57a.ada | 134 +++ gcc/testsuite/ada/acats/tests/c8/c87b62a.ada | 79 ++ gcc/testsuite/ada/acats/tests/c8/c87b62b.ada | 99 ++ gcc/testsuite/ada/acats/tests/c8/c87b62c.ada | 80 ++ gcc/testsuite/ada/acats/tests/c8/c87b62d.tst | 105 +++ gcc/testsuite/ada/acats/tests/c9/c910001.a | 224 +++++ gcc/testsuite/ada/acats/tests/c9/c910002.a | 143 +++ gcc/testsuite/ada/acats/tests/c9/c910003.a | 185 ++++ gcc/testsuite/ada/acats/tests/c9/c91004b.ada | 108 +++ gcc/testsuite/ada/acats/tests/c9/c91004c.ada | 82 ++ gcc/testsuite/ada/acats/tests/c9/c91006a.ada | 82 ++ gcc/testsuite/ada/acats/tests/c9/c91007a.ada | 97 ++ gcc/testsuite/ada/acats/tests/c9/c92002a.ada | 73 ++ gcc/testsuite/ada/acats/tests/c9/c92003a.ada | 117 +++ gcc/testsuite/ada/acats/tests/c9/c92005a.ada | 75 ++ gcc/testsuite/ada/acats/tests/c9/c92005b.ada | 72 ++ gcc/testsuite/ada/acats/tests/c9/c92006a.ada | 93 ++ gcc/testsuite/ada/acats/tests/c9/c930001.a | 153 +++ gcc/testsuite/ada/acats/tests/c9/c93001a.ada | 296 ++++++ gcc/testsuite/ada/acats/tests/c9/c93002a.ada | 231 +++++ gcc/testsuite/ada/acats/tests/c9/c93003a.ada | 351 +++++++ gcc/testsuite/ada/acats/tests/c9/c93004a.ada | 67 ++ gcc/testsuite/ada/acats/tests/c9/c93004b.ada | 132 +++ gcc/testsuite/ada/acats/tests/c9/c93004c.ada | 136 +++ gcc/testsuite/ada/acats/tests/c9/c93004d.ada | 152 +++ gcc/testsuite/ada/acats/tests/c9/c93004f.ada | 130 +++ gcc/testsuite/ada/acats/tests/c9/c93005a.ada | 130 +++ gcc/testsuite/ada/acats/tests/c9/c93005b.ada | 273 ++++++ gcc/testsuite/ada/acats/tests/c9/c93005c.ada | 250 +++++ gcc/testsuite/ada/acats/tests/c9/c93005d.ada | 289 ++++++ gcc/testsuite/ada/acats/tests/c9/c93005e.ada | 247 +++++ gcc/testsuite/ada/acats/tests/c9/c93005f.ada | 255 +++++ gcc/testsuite/ada/acats/tests/c9/c93005g.ada | 245 +++++ gcc/testsuite/ada/acats/tests/c9/c93005h.ada | 250 +++++ gcc/testsuite/ada/acats/tests/c9/c93006a.ada | 69 ++ gcc/testsuite/ada/acats/tests/c9/c93007a.ada | 113 +++ gcc/testsuite/ada/acats/tests/c9/c93008a.ada | 108 +++ gcc/testsuite/ada/acats/tests/c9/c93008b.ada | 103 ++ gcc/testsuite/ada/acats/tests/c9/c940001.a | 212 +++++ gcc/testsuite/ada/acats/tests/c9/c940002.a | 309 ++++++ gcc/testsuite/ada/acats/tests/c9/c940004.a | 416 ++++++++ gcc/testsuite/ada/acats/tests/c9/c940005.a | 370 ++++++++ gcc/testsuite/ada/acats/tests/c9/c940006.a | 223 +++++ gcc/testsuite/ada/acats/tests/c9/c940007.a | 427 +++++++++ gcc/testsuite/ada/acats/tests/c9/c940010.a | 269 ++++++ gcc/testsuite/ada/acats/tests/c9/c940011.a | 175 ++++ gcc/testsuite/ada/acats/tests/c9/c940012.a | 174 ++++ gcc/testsuite/ada/acats/tests/c9/c940013.a | 379 ++++++++ gcc/testsuite/ada/acats/tests/c9/c940014.a | 177 ++++ gcc/testsuite/ada/acats/tests/c9/c940015.a | 149 +++ gcc/testsuite/ada/acats/tests/c9/c940016.a | 211 +++++ gcc/testsuite/ada/acats/tests/c9/c94001a.ada | 259 +++++ gcc/testsuite/ada/acats/tests/c9/c94001b.ada | 268 ++++++ gcc/testsuite/ada/acats/tests/c9/c94001c.ada | 267 ++++++ gcc/testsuite/ada/acats/tests/c9/c94001e.ada | 81 ++ gcc/testsuite/ada/acats/tests/c9/c94001f.ada | 80 ++ gcc/testsuite/ada/acats/tests/c9/c94001g.ada | 124 +++ gcc/testsuite/ada/acats/tests/c9/c94002a.ada | 331 +++++++ gcc/testsuite/ada/acats/tests/c9/c94002b.ada | 208 ++++ gcc/testsuite/ada/acats/tests/c9/c94002d.ada | 74 ++ gcc/testsuite/ada/acats/tests/c9/c94002e.ada | 207 ++++ gcc/testsuite/ada/acats/tests/c9/c94002f.ada | 227 +++++ gcc/testsuite/ada/acats/tests/c9/c94002g.ada | 350 +++++++ gcc/testsuite/ada/acats/tests/c9/c94004a.ada | 95 ++ gcc/testsuite/ada/acats/tests/c9/c94004b.ada | 97 ++ gcc/testsuite/ada/acats/tests/c9/c94004c.ada | 104 ++ gcc/testsuite/ada/acats/tests/c9/c94005a.ada | 90 ++ gcc/testsuite/ada/acats/tests/c9/c94005b.ada | 168 ++++ gcc/testsuite/ada/acats/tests/c9/c94006a.ada | 136 +++ gcc/testsuite/ada/acats/tests/c9/c94007a.ada | 270 ++++++ gcc/testsuite/ada/acats/tests/c9/c94007b.ada | 224 +++++ gcc/testsuite/ada/acats/tests/c9/c94008a.ada | 61 ++ gcc/testsuite/ada/acats/tests/c9/c94008b.ada | 81 ++ gcc/testsuite/ada/acats/tests/c9/c94008c.ada | 265 ++++++ gcc/testsuite/ada/acats/tests/c9/c94008d.ada | 235 +++++ gcc/testsuite/ada/acats/tests/c9/c94010a.ada | 243 +++++ gcc/testsuite/ada/acats/tests/c9/c94011a.ada | 268 ++++++ gcc/testsuite/ada/acats/tests/c9/c94020a.ada | 111 +++ gcc/testsuite/ada/acats/tests/c9/c940a03.a | 350 +++++++ gcc/testsuite/ada/acats/tests/c9/c95008a.ada | 426 +++++++++ gcc/testsuite/ada/acats/tests/c9/c95009a.ada | 121 +++ gcc/testsuite/ada/acats/tests/c9/c95010a.ada | 82 ++ gcc/testsuite/ada/acats/tests/c9/c95011a.ada | 67 ++ gcc/testsuite/ada/acats/tests/c9/c95012a.ada | 106 +++ gcc/testsuite/ada/acats/tests/c9/c95021a.ada | 182 ++++ gcc/testsuite/ada/acats/tests/c9/c95022a.ada | 115 +++ gcc/testsuite/ada/acats/tests/c9/c95022b.ada | 112 +++ gcc/testsuite/ada/acats/tests/c9/c95033a.ada | 74 ++ gcc/testsuite/ada/acats/tests/c9/c95033b.ada | 67 ++ gcc/testsuite/ada/acats/tests/c9/c95034a.ada | 85 ++ gcc/testsuite/ada/acats/tests/c9/c95034b.ada | 83 ++ gcc/testsuite/ada/acats/tests/c9/c95035a.ada | 78 ++ gcc/testsuite/ada/acats/tests/c9/c95040a.ada | 59 ++ gcc/testsuite/ada/acats/tests/c9/c95040b.ada | 63 ++ gcc/testsuite/ada/acats/tests/c9/c95040c.ada | 86 ++ gcc/testsuite/ada/acats/tests/c9/c95040d.ada | 122 +++ gcc/testsuite/ada/acats/tests/c9/c95041a.ada | 97 ++ gcc/testsuite/ada/acats/tests/c9/c95065a.ada | 91 ++ gcc/testsuite/ada/acats/tests/c9/c95065b.ada | 91 ++ gcc/testsuite/ada/acats/tests/c9/c95065c.ada | 97 ++ gcc/testsuite/ada/acats/tests/c9/c95065d.ada | 92 ++ gcc/testsuite/ada/acats/tests/c9/c95065e.ada | 92 ++ gcc/testsuite/ada/acats/tests/c9/c95065f.ada | 97 ++ gcc/testsuite/ada/acats/tests/c9/c95066a.ada | 214 +++++ gcc/testsuite/ada/acats/tests/c9/c95067a.ada | 302 ++++++ gcc/testsuite/ada/acats/tests/c9/c95071a.ada | 230 +++++ gcc/testsuite/ada/acats/tests/c9/c95072a.ada | 197 ++++ gcc/testsuite/ada/acats/tests/c9/c95072b.ada | 278 ++++++ gcc/testsuite/ada/acats/tests/c9/c95073a.ada | 66 ++ gcc/testsuite/ada/acats/tests/c9/c95074c.ada | 103 ++ gcc/testsuite/ada/acats/tests/c9/c95076a.ada | 85 ++ gcc/testsuite/ada/acats/tests/c9/c95078a.ada | 195 ++++ gcc/testsuite/ada/acats/tests/c9/c95080b.ada | 71 ++ gcc/testsuite/ada/acats/tests/c9/c95082g.ada | 91 ++ gcc/testsuite/ada/acats/tests/c9/c95085a.ada | 279 ++++++ gcc/testsuite/ada/acats/tests/c9/c95085b.ada | 183 ++++ gcc/testsuite/ada/acats/tests/c9/c95085c.ada | 245 +++++ gcc/testsuite/ada/acats/tests/c9/c95085d.ada | 97 ++ gcc/testsuite/ada/acats/tests/c9/c95085e.ada | 87 ++ gcc/testsuite/ada/acats/tests/c9/c95085f.ada | 84 ++ gcc/testsuite/ada/acats/tests/c9/c95085g.ada | 98 ++ gcc/testsuite/ada/acats/tests/c9/c95085h.ada | 111 +++ gcc/testsuite/ada/acats/tests/c9/c95085i.ada | 100 ++ gcc/testsuite/ada/acats/tests/c9/c95085j.ada | 90 ++ gcc/testsuite/ada/acats/tests/c9/c95085k.ada | 97 ++ gcc/testsuite/ada/acats/tests/c9/c95085l.ada | 109 +++ gcc/testsuite/ada/acats/tests/c9/c95085m.ada | 96 ++ gcc/testsuite/ada/acats/tests/c9/c95085n.ada | 117 +++ gcc/testsuite/ada/acats/tests/c9/c95085o.ada | 118 +++ gcc/testsuite/ada/acats/tests/c9/c95086a.ada | 94 ++ gcc/testsuite/ada/acats/tests/c9/c95086b.ada | 202 ++++ gcc/testsuite/ada/acats/tests/c9/c95086c.ada | 250 +++++ gcc/testsuite/ada/acats/tests/c9/c95086d.ada | 142 +++ gcc/testsuite/ada/acats/tests/c9/c95086e.ada | 282 ++++++ gcc/testsuite/ada/acats/tests/c9/c95086f.ada | 282 ++++++ gcc/testsuite/ada/acats/tests/c9/c95087a.ada | 412 ++++++++ gcc/testsuite/ada/acats/tests/c9/c95087b.ada | 267 ++++++ gcc/testsuite/ada/acats/tests/c9/c95087c.ada | 299 ++++++ gcc/testsuite/ada/acats/tests/c9/c95087d.ada | 268 ++++++ gcc/testsuite/ada/acats/tests/c9/c95088a.ada | 85 ++ gcc/testsuite/ada/acats/tests/c9/c95089a.ada | 175 ++++ gcc/testsuite/ada/acats/tests/c9/c95090a.ada | 128 +++ gcc/testsuite/ada/acats/tests/c9/c95092a.ada | 193 ++++ gcc/testsuite/ada/acats/tests/c9/c95093a.ada | 87 ++ gcc/testsuite/ada/acats/tests/c9/c95095a.ada | 108 +++ gcc/testsuite/ada/acats/tests/c9/c95095b.ada | 112 +++ gcc/testsuite/ada/acats/tests/c9/c95095c.ada | 97 ++ gcc/testsuite/ada/acats/tests/c9/c95095d.ada | 99 ++ gcc/testsuite/ada/acats/tests/c9/c95095e.ada | 88 ++ gcc/testsuite/ada/acats/tests/c9/c951001.a | 192 ++++ gcc/testsuite/ada/acats/tests/c9/c951002.a | 334 +++++++ gcc/testsuite/ada/acats/tests/c9/c953001.a | 188 ++++ gcc/testsuite/ada/acats/tests/c9/c953002.a | 242 +++++ gcc/testsuite/ada/acats/tests/c9/c953003.a | 189 ++++ gcc/testsuite/ada/acats/tests/c9/c954001.a | 273 ++++++ gcc/testsuite/ada/acats/tests/c9/c954010.a | 286 ++++++ gcc/testsuite/ada/acats/tests/c9/c954011.a | 384 ++++++++ gcc/testsuite/ada/acats/tests/c9/c954012.a | 496 ++++++++++ gcc/testsuite/ada/acats/tests/c9/c954013.a | 521 +++++++++++ gcc/testsuite/ada/acats/tests/c9/c954014.a | 485 ++++++++++ gcc/testsuite/ada/acats/tests/c9/c954015.a | 549 +++++++++++ gcc/testsuite/ada/acats/tests/c9/c954016.a | 182 ++++ gcc/testsuite/ada/acats/tests/c9/c954017.a | 184 ++++ gcc/testsuite/ada/acats/tests/c9/c954018.a | 227 +++++ gcc/testsuite/ada/acats/tests/c9/c954019.a | 314 +++++++ gcc/testsuite/ada/acats/tests/c9/c954020.a | 422 +++++++++ gcc/testsuite/ada/acats/tests/c9/c954021.a | 524 +++++++++++ gcc/testsuite/ada/acats/tests/c9/c954022.a | 351 +++++++ gcc/testsuite/ada/acats/tests/c9/c954023.a | 558 +++++++++++ gcc/testsuite/ada/acats/tests/c9/c954024.a | 380 ++++++++ gcc/testsuite/ada/acats/tests/c9/c954025.a | 237 +++++ gcc/testsuite/ada/acats/tests/c9/c954026.a | 269 ++++++ gcc/testsuite/ada/acats/tests/c9/c954a01.a | 262 ++++++ gcc/testsuite/ada/acats/tests/c9/c954a02.a | 259 +++++ gcc/testsuite/ada/acats/tests/c9/c954a03.a | 322 +++++++ gcc/testsuite/ada/acats/tests/c9/c960001.a | 164 ++++ gcc/testsuite/ada/acats/tests/c9/c960002.a | 171 ++++ gcc/testsuite/ada/acats/tests/c9/c960004.a | 206 ++++ gcc/testsuite/ada/acats/tests/c9/c96001a.ada | 163 ++++ gcc/testsuite/ada/acats/tests/c9/c96004a.ada | 258 +++++ gcc/testsuite/ada/acats/tests/c9/c96005a.ada | 239 +++++ gcc/testsuite/ada/acats/tests/c9/c96005b.tst | 135 +++ gcc/testsuite/ada/acats/tests/c9/c96005d.ada | 81 ++ gcc/testsuite/ada/acats/tests/c9/c96005f.ada | 93 ++ gcc/testsuite/ada/acats/tests/c9/c96006a.ada | 298 ++++++ gcc/testsuite/ada/acats/tests/c9/c96007a.ada | 203 ++++ gcc/testsuite/ada/acats/tests/c9/c96008a.ada | 203 ++++ gcc/testsuite/ada/acats/tests/c9/c96008b.ada | 71 ++ gcc/testsuite/ada/acats/tests/c9/c97112a.ada | 134 +++ gcc/testsuite/ada/acats/tests/c9/c97113a.ada | 113 +++ gcc/testsuite/ada/acats/tests/c9/c97114a.ada | 196 ++++ gcc/testsuite/ada/acats/tests/c9/c97115a.ada | 189 ++++ gcc/testsuite/ada/acats/tests/c9/c97116a.ada | 102 ++ gcc/testsuite/ada/acats/tests/c9/c97117a.ada | 72 ++ gcc/testsuite/ada/acats/tests/c9/c97117b.ada | 88 ++ gcc/testsuite/ada/acats/tests/c9/c97117c.ada | 74 ++ gcc/testsuite/ada/acats/tests/c9/c97118a.ada | 73 ++ gcc/testsuite/ada/acats/tests/c9/c97120a.ada | 81 ++ gcc/testsuite/ada/acats/tests/c9/c97120b.ada | 103 ++ gcc/testsuite/ada/acats/tests/c9/c97201a.ada | 151 +++ gcc/testsuite/ada/acats/tests/c9/c97201b.ada | 108 +++ gcc/testsuite/ada/acats/tests/c9/c97201c.ada | 70 ++ gcc/testsuite/ada/acats/tests/c9/c97201d.ada | 102 ++ gcc/testsuite/ada/acats/tests/c9/c97201e.ada | 107 +++ gcc/testsuite/ada/acats/tests/c9/c97201g.ada | 133 +++ gcc/testsuite/ada/acats/tests/c9/c97201h.ada | 133 +++ gcc/testsuite/ada/acats/tests/c9/c97201x.ada | 170 ++++ gcc/testsuite/ada/acats/tests/c9/c97202a.ada | 100 ++ gcc/testsuite/ada/acats/tests/c9/c97203a.ada | 125 +++ gcc/testsuite/ada/acats/tests/c9/c97203b.ada | 131 +++ gcc/testsuite/ada/acats/tests/c9/c97203c.ada | 124 +++ gcc/testsuite/ada/acats/tests/c9/c97204a.ada | 122 +++ gcc/testsuite/ada/acats/tests/c9/c97204b.ada | 82 ++ gcc/testsuite/ada/acats/tests/c9/c97205a.ada | 94 ++ gcc/testsuite/ada/acats/tests/c9/c97205b.ada | 98 ++ gcc/testsuite/ada/acats/tests/c9/c97301a.ada | 158 ++++ gcc/testsuite/ada/acats/tests/c9/c97301b.ada | 147 +++ gcc/testsuite/ada/acats/tests/c9/c97301c.ada | 101 ++ gcc/testsuite/ada/acats/tests/c9/c97301d.ada | 106 +++ gcc/testsuite/ada/acats/tests/c9/c97301e.ada | 118 +++ gcc/testsuite/ada/acats/tests/c9/c97302a.ada | 116 +++ gcc/testsuite/ada/acats/tests/c9/c97303a.ada | 128 +++ gcc/testsuite/ada/acats/tests/c9/c97303b.ada | 133 +++ gcc/testsuite/ada/acats/tests/c9/c97303c.ada | 128 +++ gcc/testsuite/ada/acats/tests/c9/c97304a.ada | 123 +++ gcc/testsuite/ada/acats/tests/c9/c97304b.ada | 84 ++ gcc/testsuite/ada/acats/tests/c9/c97305a.ada | 100 ++ gcc/testsuite/ada/acats/tests/c9/c97305b.ada | 104 ++ gcc/testsuite/ada/acats/tests/c9/c97305c.ada | 90 ++ gcc/testsuite/ada/acats/tests/c9/c97305d.ada | 95 ++ gcc/testsuite/ada/acats/tests/c9/c97307a.ada | 209 +++++ gcc/testsuite/ada/acats/tests/c9/c974001.a | 152 +++ gcc/testsuite/ada/acats/tests/c9/c974002.a | 209 +++++ gcc/testsuite/ada/acats/tests/c9/c974003.a | 249 +++++ gcc/testsuite/ada/acats/tests/c9/c974004.a | 273 ++++++ gcc/testsuite/ada/acats/tests/c9/c974005.a | 259 +++++ gcc/testsuite/ada/acats/tests/c9/c974006.a | 197 ++++ gcc/testsuite/ada/acats/tests/c9/c974007.a | 205 ++++ gcc/testsuite/ada/acats/tests/c9/c974008.a | 229 +++++ gcc/testsuite/ada/acats/tests/c9/c974009.a | 206 ++++ gcc/testsuite/ada/acats/tests/c9/c974010.a | 209 +++++ gcc/testsuite/ada/acats/tests/c9/c974011.a | 275 ++++++ gcc/testsuite/ada/acats/tests/c9/c974012.a | 165 ++++ gcc/testsuite/ada/acats/tests/c9/c974013.a | 167 ++++ gcc/testsuite/ada/acats/tests/c9/c974014.a | 132 +++ gcc/testsuite/ada/acats/tests/c9/c980001.a | 303 ++++++ gcc/testsuite/ada/acats/tests/c9/c980002.a | 165 ++++ gcc/testsuite/ada/acats/tests/c9/c980003.a | 294 ++++++ gcc/testsuite/ada/acats/tests/c9/c99004a.ada | 166 ++++ gcc/testsuite/ada/acats/tests/c9/c99005a.ada | 183 ++++ gcc/testsuite/ada/acats/tests/c9/c9a003a.ada | 105 +++ gcc/testsuite/ada/acats/tests/c9/c9a004a.ada | 108 +++ gcc/testsuite/ada/acats/tests/c9/c9a007a.ada | 293 ++++++ gcc/testsuite/ada/acats/tests/c9/c9a009a.ada | 117 +++ gcc/testsuite/ada/acats/tests/c9/c9a009c.ada | 95 ++ gcc/testsuite/ada/acats/tests/c9/c9a009f.ada | 88 ++ gcc/testsuite/ada/acats/tests/c9/c9a009g.ada | 95 ++ gcc/testsuite/ada/acats/tests/c9/c9a009h.ada | 77 ++ gcc/testsuite/ada/acats/tests/c9/c9a010a.ada | 89 ++ gcc/testsuite/ada/acats/tests/c9/c9a011a.ada | 71 ++ gcc/testsuite/ada/acats/tests/c9/c9a011b.ada | 102 ++ gcc/testsuite/ada/acats/tests/ca/ca1003a.ada | 73 ++ gcc/testsuite/ada/acats/tests/ca/ca1004a.ada | 77 ++ gcc/testsuite/ada/acats/tests/ca/ca1005a.ada | 70 ++ gcc/testsuite/ada/acats/tests/ca/ca1006a.ada | 106 +++ gcc/testsuite/ada/acats/tests/ca/ca1011a0.ada | 35 + gcc/testsuite/ada/acats/tests/ca/ca1011a1.ada | 36 + gcc/testsuite/ada/acats/tests/ca/ca1011a2.ada | 35 + gcc/testsuite/ada/acats/tests/ca/ca1011a3.ada | 34 + gcc/testsuite/ada/acats/tests/ca/ca1011a4.ada | 35 + gcc/testsuite/ada/acats/tests/ca/ca1011a5.ada | 33 + gcc/testsuite/ada/acats/tests/ca/ca1011a6.ada | 71 ++ gcc/testsuite/ada/acats/tests/ca/ca1012a0.ada | 41 + gcc/testsuite/ada/acats/tests/ca/ca1012a1.ada | 45 + gcc/testsuite/ada/acats/tests/ca/ca1012a2.ada | 41 + gcc/testsuite/ada/acats/tests/ca/ca1012a3.ada | 45 + gcc/testsuite/ada/acats/tests/ca/ca1012a4.ada | 74 ++ gcc/testsuite/ada/acats/tests/ca/ca1012b0.ada | 37 + gcc/testsuite/ada/acats/tests/ca/ca1012b2.ada | 37 + gcc/testsuite/ada/acats/tests/ca/ca1012b4.ada | 63 ++ gcc/testsuite/ada/acats/tests/ca/ca1013a0.ada | 51 + gcc/testsuite/ada/acats/tests/ca/ca1013a1.ada | 39 + gcc/testsuite/ada/acats/tests/ca/ca1013a2.ada | 39 + gcc/testsuite/ada/acats/tests/ca/ca1013a3.ada | 31 + gcc/testsuite/ada/acats/tests/ca/ca1013a4.ada | 31 + gcc/testsuite/ada/acats/tests/ca/ca1013a5.ada | 30 + gcc/testsuite/ada/acats/tests/ca/ca1013a6.ada | 65 ++ gcc/testsuite/ada/acats/tests/ca/ca1014a0.ada | 85 ++ gcc/testsuite/ada/acats/tests/ca/ca1014a1.ada | 34 + gcc/testsuite/ada/acats/tests/ca/ca1014a2.ada | 39 + gcc/testsuite/ada/acats/tests/ca/ca1014a3.ada | 34 + gcc/testsuite/ada/acats/tests/ca/ca1020e0.ada | 53 ++ gcc/testsuite/ada/acats/tests/ca/ca1020e1.ada | 59 ++ gcc/testsuite/ada/acats/tests/ca/ca1020e2.ada | 51 + gcc/testsuite/ada/acats/tests/ca/ca1020e3.ada | 71 ++ gcc/testsuite/ada/acats/tests/ca/ca1022a0.ada | 43 + gcc/testsuite/ada/acats/tests/ca/ca1022a1.ada | 33 + gcc/testsuite/ada/acats/tests/ca/ca1022a2.ada | 33 + gcc/testsuite/ada/acats/tests/ca/ca1022a3.ada | 53 ++ gcc/testsuite/ada/acats/tests/ca/ca1022a4.ada | 36 + gcc/testsuite/ada/acats/tests/ca/ca1022a5.ada | 34 + gcc/testsuite/ada/acats/tests/ca/ca1022a6.ada | 66 ++ gcc/testsuite/ada/acats/tests/ca/ca11001.a | 276 ++++++ gcc/testsuite/ada/acats/tests/ca/ca11002.a | 238 +++++ gcc/testsuite/ada/acats/tests/ca/ca11003.a | 290 ++++++ gcc/testsuite/ada/acats/tests/ca/ca110040.a | 90 ++ gcc/testsuite/ada/acats/tests/ca/ca110041.a | 118 +++ gcc/testsuite/ada/acats/tests/ca/ca110042.am | 130 +++ gcc/testsuite/ada/acats/tests/ca/ca110050.a | 99 ++ gcc/testsuite/ada/acats/tests/ca/ca110051.am | 224 +++++ gcc/testsuite/ada/acats/tests/ca/ca11006.a | 211 +++++ gcc/testsuite/ada/acats/tests/ca/ca11007.a | 228 +++++ gcc/testsuite/ada/acats/tests/ca/ca11008.a | 216 +++++ gcc/testsuite/ada/acats/tests/ca/ca11009.a | 246 +++++ gcc/testsuite/ada/acats/tests/ca/ca11010.a | 254 +++++ gcc/testsuite/ada/acats/tests/ca/ca11011.a | 271 ++++++ gcc/testsuite/ada/acats/tests/ca/ca11012.a | 259 +++++ gcc/testsuite/ada/acats/tests/ca/ca11013.a | 201 ++++ gcc/testsuite/ada/acats/tests/ca/ca11014.a | 302 ++++++ gcc/testsuite/ada/acats/tests/ca/ca11015.a | 312 ++++++ gcc/testsuite/ada/acats/tests/ca/ca11016.a | 321 +++++++ gcc/testsuite/ada/acats/tests/ca/ca11017.a | 246 +++++ gcc/testsuite/ada/acats/tests/ca/ca11018.a | 366 ++++++++ gcc/testsuite/ada/acats/tests/ca/ca11019.a | 306 ++++++ gcc/testsuite/ada/acats/tests/ca/ca11020.a | 238 +++++ gcc/testsuite/ada/acats/tests/ca/ca11021.a | 245 +++++ gcc/testsuite/ada/acats/tests/ca/ca11022.a | 242 +++++ gcc/testsuite/ada/acats/tests/ca/ca1102a0.ada | 31 + gcc/testsuite/ada/acats/tests/ca/ca1102a1.ada | 36 + gcc/testsuite/ada/acats/tests/ca/ca1102a2.ada | 58 ++ gcc/testsuite/ada/acats/tests/ca/ca1106a.ada | 112 +++ gcc/testsuite/ada/acats/tests/ca/ca1108a.ada | 136 +++ gcc/testsuite/ada/acats/tests/ca/ca1108b.ada | 168 ++++ gcc/testsuite/ada/acats/tests/ca/ca11a01.a | 228 +++++ gcc/testsuite/ada/acats/tests/ca/ca11a02.a | 156 +++ gcc/testsuite/ada/acats/tests/ca/ca11b01.a | 208 ++++ gcc/testsuite/ada/acats/tests/ca/ca11b02.a | 169 ++++ gcc/testsuite/ada/acats/tests/ca/ca11c01.a | 170 ++++ gcc/testsuite/ada/acats/tests/ca/ca11c02.a | 158 ++++ gcc/testsuite/ada/acats/tests/ca/ca11c03.a | 186 ++++ gcc/testsuite/ada/acats/tests/ca/ca11d010.a | 119 +++ gcc/testsuite/ada/acats/tests/ca/ca11d011.a | 79 ++ gcc/testsuite/ada/acats/tests/ca/ca11d012.a | 73 ++ gcc/testsuite/ada/acats/tests/ca/ca11d013.am | 256 +++++ gcc/testsuite/ada/acats/tests/ca/ca11d02.a | 393 ++++++++ gcc/testsuite/ada/acats/tests/ca/ca11d03.a | 174 ++++ gcc/testsuite/ada/acats/tests/ca/ca13001.a | 370 ++++++++ gcc/testsuite/ada/acats/tests/ca/ca13002.a | 259 +++++ gcc/testsuite/ada/acats/tests/ca/ca13003.a | 256 +++++ gcc/testsuite/ada/acats/tests/ca/ca13a01.a | 320 +++++++ gcc/testsuite/ada/acats/tests/ca/ca13a02.a | 301 ++++++ gcc/testsuite/ada/acats/tests/ca/ca140230.a | 62 ++ gcc/testsuite/ada/acats/tests/ca/ca140231.a | 59 ++ gcc/testsuite/ada/acats/tests/ca/ca140232.am | 139 +++ gcc/testsuite/ada/acats/tests/ca/ca140233.a | 68 ++ gcc/testsuite/ada/acats/tests/ca/ca140280.a | 77 ++ gcc/testsuite/ada/acats/tests/ca/ca140281.a | 67 ++ gcc/testsuite/ada/acats/tests/ca/ca140282.a | 64 ++ gcc/testsuite/ada/acats/tests/ca/ca140283.am | 91 ++ gcc/testsuite/ada/acats/tests/ca/ca15003.a | 161 ++++ gcc/testsuite/ada/acats/tests/ca/ca200020.a | 70 ++ gcc/testsuite/ada/acats/tests/ca/ca200021.a | 66 ++ gcc/testsuite/ada/acats/tests/ca/ca200022.am | 64 ++ gcc/testsuite/ada/acats/tests/ca/ca2001h0.ada | 40 + gcc/testsuite/ada/acats/tests/ca/ca2001h1.ada | 39 + gcc/testsuite/ada/acats/tests/ca/ca2001h2.ada | 38 + gcc/testsuite/ada/acats/tests/ca/ca2001h3.ada | 66 ++ gcc/testsuite/ada/acats/tests/ca/ca2002a0.ada | 139 +++ gcc/testsuite/ada/acats/tests/ca/ca2002a1.ada | 53 ++ gcc/testsuite/ada/acats/tests/ca/ca2002a2.ada | 53 ++ gcc/testsuite/ada/acats/tests/ca/ca2003a0.ada | 55 ++ gcc/testsuite/ada/acats/tests/ca/ca2003a1.ada | 35 + gcc/testsuite/ada/acats/tests/ca/ca2004a0.ada | 65 ++ gcc/testsuite/ada/acats/tests/ca/ca2004a1.ada | 34 + gcc/testsuite/ada/acats/tests/ca/ca2004a2.ada | 43 + gcc/testsuite/ada/acats/tests/ca/ca2004a3.ada | 39 + gcc/testsuite/ada/acats/tests/ca/ca2004a4.ada | 36 + gcc/testsuite/ada/acats/tests/ca/ca2007a0.ada | 77 ++ gcc/testsuite/ada/acats/tests/ca/ca2007a1.ada | 36 + gcc/testsuite/ada/acats/tests/ca/ca2007a2.ada | 36 + gcc/testsuite/ada/acats/tests/ca/ca2007a3.ada | 36 + gcc/testsuite/ada/acats/tests/ca/ca2008a0.ada | 81 ++ gcc/testsuite/ada/acats/tests/ca/ca2008a1.ada | 35 + gcc/testsuite/ada/acats/tests/ca/ca2008a2.ada | 35 + gcc/testsuite/ada/acats/tests/ca/ca2009a.ada | 77 ++ gcc/testsuite/ada/acats/tests/ca/ca2009c0.ada | 83 ++ gcc/testsuite/ada/acats/tests/ca/ca2009c1.ada | 43 + gcc/testsuite/ada/acats/tests/ca/ca2009d.ada | 95 ++ gcc/testsuite/ada/acats/tests/ca/ca2009f0.ada | 134 +++ gcc/testsuite/ada/acats/tests/ca/ca2009f1.ada | 43 + gcc/testsuite/ada/acats/tests/ca/ca2009f2.ada | 45 + gcc/testsuite/ada/acats/tests/ca/ca2011b.ada | 118 +++ gcc/testsuite/ada/acats/tests/ca/ca21001.a | 152 +++ gcc/testsuite/ada/acats/tests/ca/ca3011a0.ada | 74 ++ gcc/testsuite/ada/acats/tests/ca/ca3011a1.ada | 42 + gcc/testsuite/ada/acats/tests/ca/ca3011a2.ada | 42 + gcc/testsuite/ada/acats/tests/ca/ca3011a3.ada | 43 + gcc/testsuite/ada/acats/tests/ca/ca3011a4.ada | 61 ++ gcc/testsuite/ada/acats/tests/ca/ca5003a0.ada | 50 + gcc/testsuite/ada/acats/tests/ca/ca5003a1.ada | 34 + gcc/testsuite/ada/acats/tests/ca/ca5003a2.ada | 34 + gcc/testsuite/ada/acats/tests/ca/ca5003a3.ada | 34 + gcc/testsuite/ada/acats/tests/ca/ca5003a4.ada | 34 + gcc/testsuite/ada/acats/tests/ca/ca5003a5.ada | 34 + gcc/testsuite/ada/acats/tests/ca/ca5003a6.ada | 71 ++ gcc/testsuite/ada/acats/tests/ca/ca5003b0.ada | 51 + gcc/testsuite/ada/acats/tests/ca/ca5003b1.ada | 46 + gcc/testsuite/ada/acats/tests/ca/ca5003b2.ada | 45 + gcc/testsuite/ada/acats/tests/ca/ca5003b3.ada | 35 + gcc/testsuite/ada/acats/tests/ca/ca5003b4.ada | 40 + gcc/testsuite/ada/acats/tests/ca/ca5003b5.ada | 65 ++ gcc/testsuite/ada/acats/tests/ca/ca5004a.ada | 105 +++ gcc/testsuite/ada/acats/tests/ca/ca5004b0.ada | 64 ++ gcc/testsuite/ada/acats/tests/ca/ca5004b1.ada | 56 ++ gcc/testsuite/ada/acats/tests/ca/ca5004b2.ada | 153 +++ gcc/testsuite/ada/acats/tests/ca/ca5006a.ada | 145 +++ gcc/testsuite/ada/acats/tests/cb/cb10002.a | 128 +++ gcc/testsuite/ada/acats/tests/cb/cb1001a.ada | 102 ++ gcc/testsuite/ada/acats/tests/cb/cb1004a.ada | 85 ++ gcc/testsuite/ada/acats/tests/cb/cb1005a.ada | 164 ++++ gcc/testsuite/ada/acats/tests/cb/cb1010a.ada | 179 ++++ gcc/testsuite/ada/acats/tests/cb/cb1010c.ada | 70 ++ gcc/testsuite/ada/acats/tests/cb/cb1010d.ada | 92 ++ gcc/testsuite/ada/acats/tests/cb/cb20001.a | 228 +++++ gcc/testsuite/ada/acats/tests/cb/cb20003.a | 286 ++++++ gcc/testsuite/ada/acats/tests/cb/cb20004.a | 203 ++++ gcc/testsuite/ada/acats/tests/cb/cb20005.a | 210 +++++ gcc/testsuite/ada/acats/tests/cb/cb20006.a | 217 +++++ gcc/testsuite/ada/acats/tests/cb/cb20007.a | 196 ++++ gcc/testsuite/ada/acats/tests/cb/cb2004a.ada | 245 +++++ gcc/testsuite/ada/acats/tests/cb/cb2005a.ada | 77 ++ gcc/testsuite/ada/acats/tests/cb/cb2006a.ada | 70 ++ gcc/testsuite/ada/acats/tests/cb/cb2007a.ada | 104 ++ gcc/testsuite/ada/acats/tests/cb/cb20a02.a | 155 +++ gcc/testsuite/ada/acats/tests/cb/cb3003a.ada | 164 ++++ gcc/testsuite/ada/acats/tests/cb/cb3003b.ada | 135 +++ gcc/testsuite/ada/acats/tests/cb/cb3004a.ada | 145 +++ gcc/testsuite/ada/acats/tests/cb/cb40005.a | 339 +++++++ gcc/testsuite/ada/acats/tests/cb/cb4001a.ada | 151 +++ gcc/testsuite/ada/acats/tests/cb/cb4002a.ada | 127 +++ gcc/testsuite/ada/acats/tests/cb/cb4003a.ada | 119 +++ gcc/testsuite/ada/acats/tests/cb/cb4004a.ada | 77 ++ gcc/testsuite/ada/acats/tests/cb/cb4005a.ada | 66 ++ gcc/testsuite/ada/acats/tests/cb/cb4006a.ada | 97 ++ gcc/testsuite/ada/acats/tests/cb/cb4007a.ada | 115 +++ gcc/testsuite/ada/acats/tests/cb/cb4008a.ada | 137 +++ gcc/testsuite/ada/acats/tests/cb/cb4009a.ada | 114 +++ gcc/testsuite/ada/acats/tests/cb/cb4013a.ada | 80 ++ gcc/testsuite/ada/acats/tests/cb/cb40a01.a | 135 +++ gcc/testsuite/ada/acats/tests/cb/cb40a020.a | 95 ++ gcc/testsuite/ada/acats/tests/cb/cb40a021.am | 103 ++ gcc/testsuite/ada/acats/tests/cb/cb40a030.a | 105 +++ gcc/testsuite/ada/acats/tests/cb/cb40a031.am | 102 ++ gcc/testsuite/ada/acats/tests/cb/cb40a04.a | 119 +++ gcc/testsuite/ada/acats/tests/cb/cb41001.a | 213 +++++ gcc/testsuite/ada/acats/tests/cb/cb41002.a | 283 ++++++ gcc/testsuite/ada/acats/tests/cb/cb41003.a | 358 +++++++ gcc/testsuite/ada/acats/tests/cb/cb41004.a | 299 ++++++ gcc/testsuite/ada/acats/tests/cb/cb5001a.ada | 87 ++ gcc/testsuite/ada/acats/tests/cb/cb5001b.ada | 106 +++ gcc/testsuite/ada/acats/tests/cb/cb5002a.ada | 168 ++++ gcc/testsuite/ada/acats/tests/cc/cc1004a.ada | 108 +++ gcc/testsuite/ada/acats/tests/cc/cc1005b.ada | 151 +++ gcc/testsuite/ada/acats/tests/cc/cc1010a.ada | 66 ++ gcc/testsuite/ada/acats/tests/cc/cc1010b.ada | 67 ++ gcc/testsuite/ada/acats/tests/cc/cc1018a.ada | 83 ++ gcc/testsuite/ada/acats/tests/cc/cc1104c.ada | 151 +++ gcc/testsuite/ada/acats/tests/cc/cc1107b.ada | 84 ++ gcc/testsuite/ada/acats/tests/cc/cc1111a.ada | 322 +++++++ gcc/testsuite/ada/acats/tests/cc/cc1204a.ada | 115 +++ gcc/testsuite/ada/acats/tests/cc/cc1207b.ada | 138 +++ gcc/testsuite/ada/acats/tests/cc/cc1220a.ada | 174 ++++ gcc/testsuite/ada/acats/tests/cc/cc1221a.ada | 141 +++ gcc/testsuite/ada/acats/tests/cc/cc1221b.ada | 159 ++++ gcc/testsuite/ada/acats/tests/cc/cc1221c.ada | 195 ++++ gcc/testsuite/ada/acats/tests/cc/cc1221d.ada | 173 ++++ gcc/testsuite/ada/acats/tests/cc/cc1222a.ada | 290 ++++++ gcc/testsuite/ada/acats/tests/cc/cc1223a.ada | 297 ++++++ gcc/testsuite/ada/acats/tests/cc/cc1224a.ada | 558 +++++++++++ gcc/testsuite/ada/acats/tests/cc/cc1225a.tst | 350 +++++++ gcc/testsuite/ada/acats/tests/cc/cc1226b.ada | 176 ++++ gcc/testsuite/ada/acats/tests/cc/cc1227a.ada | 289 ++++++ gcc/testsuite/ada/acats/tests/cc/cc1301a.ada | 164 ++++ gcc/testsuite/ada/acats/tests/cc/cc1302a.ada | 174 ++++ gcc/testsuite/ada/acats/tests/cc/cc1304a.ada | 122 +++ gcc/testsuite/ada/acats/tests/cc/cc1304b.ada | 166 ++++ gcc/testsuite/ada/acats/tests/cc/cc1307a.ada | 54 ++ gcc/testsuite/ada/acats/tests/cc/cc1307b.ada | 88 ++ gcc/testsuite/ada/acats/tests/cc/cc1308a.ada | 266 ++++++ gcc/testsuite/ada/acats/tests/cc/cc1310a.ada | 88 ++ gcc/testsuite/ada/acats/tests/cc/cc1311a.ada | 480 ++++++++++ gcc/testsuite/ada/acats/tests/cc/cc1311b.ada | 332 +++++++ gcc/testsuite/ada/acats/tests/cc/cc2002a.ada | 77 ++ gcc/testsuite/ada/acats/tests/cc/cc30001.a | 219 +++++ gcc/testsuite/ada/acats/tests/cc/cc30002.a | 349 +++++++ gcc/testsuite/ada/acats/tests/cc/cc3004a.ada | 87 ++ gcc/testsuite/ada/acats/tests/cc/cc3007a.ada | 118 +++ gcc/testsuite/ada/acats/tests/cc/cc3007b.ada | 397 ++++++++ gcc/testsuite/ada/acats/tests/cc/cc3011a.ada | 131 +++ gcc/testsuite/ada/acats/tests/cc/cc3011d.ada | 84 ++ gcc/testsuite/ada/acats/tests/cc/cc3012a.ada | 247 +++++ gcc/testsuite/ada/acats/tests/cc/cc3015a.ada | 104 ++ gcc/testsuite/ada/acats/tests/cc/cc3016b.ada | 396 ++++++++ gcc/testsuite/ada/acats/tests/cc/cc3016c.ada | 192 ++++ gcc/testsuite/ada/acats/tests/cc/cc3016f.ada | 187 ++++ gcc/testsuite/ada/acats/tests/cc/cc3016i.ada | 78 ++ gcc/testsuite/ada/acats/tests/cc/cc3017b.ada | 470 ++++++++++ gcc/testsuite/ada/acats/tests/cc/cc3017c.ada | 336 +++++++ gcc/testsuite/ada/acats/tests/cc/cc3019a.ada | 173 ++++ gcc/testsuite/ada/acats/tests/cc/cc3019b0.ada | 191 ++++ gcc/testsuite/ada/acats/tests/cc/cc3019b1.ada | 174 ++++ gcc/testsuite/ada/acats/tests/cc/cc3019b2.ada | 300 ++++++ gcc/testsuite/ada/acats/tests/cc/cc3019c0.ada | 191 ++++ gcc/testsuite/ada/acats/tests/cc/cc3019c1.ada | 331 +++++++ gcc/testsuite/ada/acats/tests/cc/cc3019c2.ada | 457 +++++++++ gcc/testsuite/ada/acats/tests/cc/cc3106b.ada | 207 ++++ gcc/testsuite/ada/acats/tests/cc/cc3120a.ada | 180 ++++ gcc/testsuite/ada/acats/tests/cc/cc3120b.ada | 146 +++ gcc/testsuite/ada/acats/tests/cc/cc3121a.ada | 183 ++++ gcc/testsuite/ada/acats/tests/cc/cc3123a.ada | 198 ++++ gcc/testsuite/ada/acats/tests/cc/cc3125a.ada | 111 +++ gcc/testsuite/ada/acats/tests/cc/cc3125b.ada | 148 +++ gcc/testsuite/ada/acats/tests/cc/cc3125c.ada | 148 +++ gcc/testsuite/ada/acats/tests/cc/cc3125d.ada | 148 +++ gcc/testsuite/ada/acats/tests/cc/cc3126a.ada | 188 ++++ gcc/testsuite/ada/acats/tests/cc/cc3127a.ada | 143 +++ gcc/testsuite/ada/acats/tests/cc/cc3128a.ada | 358 +++++++ gcc/testsuite/ada/acats/tests/cc/cc3203a.ada | 89 ++ gcc/testsuite/ada/acats/tests/cc/cc3207b.ada | 119 +++ gcc/testsuite/ada/acats/tests/cc/cc3220a.ada | 163 ++++ gcc/testsuite/ada/acats/tests/cc/cc3221a.ada | 107 +++ gcc/testsuite/ada/acats/tests/cc/cc3222a.ada | 116 +++ gcc/testsuite/ada/acats/tests/cc/cc3223a.ada | 114 +++ gcc/testsuite/ada/acats/tests/cc/cc3224a.ada | 313 +++++++ gcc/testsuite/ada/acats/tests/cc/cc3225a.ada | 183 ++++ gcc/testsuite/ada/acats/tests/cc/cc3230a.ada | 133 +++ gcc/testsuite/ada/acats/tests/cc/cc3231a.ada | 177 ++++ gcc/testsuite/ada/acats/tests/cc/cc3232a.ada | 179 ++++ gcc/testsuite/ada/acats/tests/cc/cc3233a.ada | 175 ++++ gcc/testsuite/ada/acats/tests/cc/cc3234a.ada | 147 +++ gcc/testsuite/ada/acats/tests/cc/cc3235a.ada | 129 +++ gcc/testsuite/ada/acats/tests/cc/cc3236a.ada | 117 +++ gcc/testsuite/ada/acats/tests/cc/cc3240a.ada | 122 +++ gcc/testsuite/ada/acats/tests/cc/cc3305a.ada | 103 ++ gcc/testsuite/ada/acats/tests/cc/cc3305b.ada | 84 ++ gcc/testsuite/ada/acats/tests/cc/cc3305c.ada | 84 ++ gcc/testsuite/ada/acats/tests/cc/cc3305d.ada | 84 ++ gcc/testsuite/ada/acats/tests/cc/cc3601a.ada | 251 +++++ gcc/testsuite/ada/acats/tests/cc/cc3601c.ada | 149 +++ gcc/testsuite/ada/acats/tests/cc/cc3602a.ada | 146 +++ gcc/testsuite/ada/acats/tests/cc/cc3603a.ada | 97 ++ gcc/testsuite/ada/acats/tests/cc/cc3605a.ada | 381 ++++++++ gcc/testsuite/ada/acats/tests/cc/cc3606a.ada | 134 +++ gcc/testsuite/ada/acats/tests/cc/cc3606b.ada | 134 +++ gcc/testsuite/ada/acats/tests/cc/cc3607b.ada | 79 ++ gcc/testsuite/ada/acats/tests/cc/cc40001.a | 403 ++++++++ gcc/testsuite/ada/acats/tests/cc/cc50001.a | 257 +++++ gcc/testsuite/ada/acats/tests/cc/cc50a01.a | 313 +++++++ gcc/testsuite/ada/acats/tests/cc/cc50a02.a | 227 +++++ gcc/testsuite/ada/acats/tests/cc/cc51001.a | 186 ++++ gcc/testsuite/ada/acats/tests/cc/cc51002.a | 198 ++++ gcc/testsuite/ada/acats/tests/cc/cc51003.a | 187 ++++ gcc/testsuite/ada/acats/tests/cc/cc51004.a | 181 ++++ gcc/testsuite/ada/acats/tests/cc/cc51006.a | 224 +++++ gcc/testsuite/ada/acats/tests/cc/cc51007.a | 305 ++++++ gcc/testsuite/ada/acats/tests/cc/cc51008.a | 124 +++ gcc/testsuite/ada/acats/tests/cc/cc51a01.a | 193 ++++ gcc/testsuite/ada/acats/tests/cc/cc51b03.a | 258 +++++ gcc/testsuite/ada/acats/tests/cc/cc51d01.a | 262 ++++++ gcc/testsuite/ada/acats/tests/cc/cc51d02.a | 244 +++++ gcc/testsuite/ada/acats/tests/cc/cc54001.a | 184 ++++ gcc/testsuite/ada/acats/tests/cc/cc54002.a | 223 +++++ gcc/testsuite/ada/acats/tests/cc/cc54003.a | 234 +++++ gcc/testsuite/ada/acats/tests/cc/cc54004.a | 295 ++++++ gcc/testsuite/ada/acats/tests/cc/cc70001.a | 309 ++++++ gcc/testsuite/ada/acats/tests/cc/cc70002.a | 241 +++++ gcc/testsuite/ada/acats/tests/cc/cc70003.a | 212 +++++ gcc/testsuite/ada/acats/tests/cc/cc70a01.a | 208 ++++ gcc/testsuite/ada/acats/tests/cc/cc70a02.a | 193 ++++ gcc/testsuite/ada/acats/tests/cc/cc70b01.a | 170 ++++ gcc/testsuite/ada/acats/tests/cc/cc70b02.a | 222 +++++ gcc/testsuite/ada/acats/tests/cc/cc70c01.a | 187 ++++ gcc/testsuite/ada/acats/tests/cc/cc70c02.a | 192 ++++ gcc/testsuite/ada/acats/tests/cd/cd10001.a | 300 ++++++ gcc/testsuite/ada/acats/tests/cd/cd10002.a | 1198 ++++++++++++++++++++++++ gcc/testsuite/ada/acats/tests/cd/cd1009a.ada | 80 ++ gcc/testsuite/ada/acats/tests/cd/cd1009b.ada | 80 ++ gcc/testsuite/ada/acats/tests/cd/cd1009d.ada | 84 ++ gcc/testsuite/ada/acats/tests/cd/cd1009e.ada | 82 ++ gcc/testsuite/ada/acats/tests/cd/cd1009f.ada | 83 ++ gcc/testsuite/ada/acats/tests/cd/cd1009g.ada | 86 ++ gcc/testsuite/ada/acats/tests/cd/cd1009h.ada | 79 ++ gcc/testsuite/ada/acats/tests/cd/cd1009i.ada | 69 ++ gcc/testsuite/ada/acats/tests/cd/cd1009j.ada | 66 ++ gcc/testsuite/ada/acats/tests/cd/cd1009k.tst | 94 ++ gcc/testsuite/ada/acats/tests/cd/cd1009l.ada | 69 ++ gcc/testsuite/ada/acats/tests/cd/cd1009m.ada | 81 ++ gcc/testsuite/ada/acats/tests/cd/cd1009n.ada | 147 +++ gcc/testsuite/ada/acats/tests/cd/cd1009o.ada | 75 ++ gcc/testsuite/ada/acats/tests/cd/cd1009p.ada | 66 ++ gcc/testsuite/ada/acats/tests/cd/cd1009q.ada | 75 ++ gcc/testsuite/ada/acats/tests/cd/cd1009r.ada | 64 ++ gcc/testsuite/ada/acats/tests/cd/cd1009s.ada | 72 ++ gcc/testsuite/ada/acats/tests/cd/cd1009t.tst | 77 ++ gcc/testsuite/ada/acats/tests/cd/cd1009u.tst | 84 ++ gcc/testsuite/ada/acats/tests/cd/cd1009v.ada | 76 ++ gcc/testsuite/ada/acats/tests/cd/cd1009w.ada | 71 ++ gcc/testsuite/ada/acats/tests/cd/cd1009x.ada | 105 +++ gcc/testsuite/ada/acats/tests/cd/cd1009y.ada | 115 +++ gcc/testsuite/ada/acats/tests/cd/cd1009z.ada | 115 +++ gcc/testsuite/ada/acats/tests/cd/cd1c03a.ada | 84 ++ gcc/testsuite/ada/acats/tests/cd/cd1c03b.ada | 78 ++ gcc/testsuite/ada/acats/tests/cd/cd1c03c.ada | 71 ++ gcc/testsuite/ada/acats/tests/cd/cd1c03e.tst | 82 ++ gcc/testsuite/ada/acats/tests/cd/cd1c03f.ada | 76 ++ gcc/testsuite/ada/acats/tests/cd/cd1c03g.ada | 65 ++ gcc/testsuite/ada/acats/tests/cd/cd1c03h.ada | 122 +++ gcc/testsuite/ada/acats/tests/cd/cd1c03i.ada | 115 +++ gcc/testsuite/ada/acats/tests/cd/cd1c04a.ada | 147 +++ gcc/testsuite/ada/acats/tests/cd/cd1c04d.ada | 80 ++ gcc/testsuite/ada/acats/tests/cd/cd1c04e.ada | 124 +++ gcc/testsuite/ada/acats/tests/cd/cd1c06a.tst | 100 ++ gcc/testsuite/ada/acats/tests/cd/cd20001.a | 275 ++++++ gcc/testsuite/ada/acats/tests/cd/cd2a21a.ada | 215 +++++ gcc/testsuite/ada/acats/tests/cd/cd2a21c.ada | 116 +++ gcc/testsuite/ada/acats/tests/cd/cd2a21e.ada | 153 +++ gcc/testsuite/ada/acats/tests/cd/cd2a22a.ada | 213 +++++ gcc/testsuite/ada/acats/tests/cd/cd2a22e.ada | 216 +++++ gcc/testsuite/ada/acats/tests/cd/cd2a22i.ada | 120 +++ gcc/testsuite/ada/acats/tests/cd/cd2a22j.ada | 125 +++ gcc/testsuite/ada/acats/tests/cd/cd2a23a.ada | 221 +++++ gcc/testsuite/ada/acats/tests/cd/cd2a23e.ada | 198 ++++ gcc/testsuite/ada/acats/tests/cd/cd2a24a.ada | 226 +++++ gcc/testsuite/ada/acats/tests/cd/cd2a24e.ada | 220 +++++ gcc/testsuite/ada/acats/tests/cd/cd2a24i.ada | 126 +++ gcc/testsuite/ada/acats/tests/cd/cd2a24j.ada | 124 +++ gcc/testsuite/ada/acats/tests/cd/cd2a31a.ada | 266 ++++++ gcc/testsuite/ada/acats/tests/cd/cd2a31c.ada | 127 +++ gcc/testsuite/ada/acats/tests/cd/cd2a31e.ada | 139 +++ gcc/testsuite/ada/acats/tests/cd/cd2a32a.ada | 272 ++++++ gcc/testsuite/ada/acats/tests/cd/cd2a32c.ada | 128 +++ gcc/testsuite/ada/acats/tests/cd/cd2a32e.ada | 263 ++++++ gcc/testsuite/ada/acats/tests/cd/cd2a32g.ada | 131 +++ gcc/testsuite/ada/acats/tests/cd/cd2a32i.ada | 135 +++ gcc/testsuite/ada/acats/tests/cd/cd2a32j.ada | 135 +++ gcc/testsuite/ada/acats/tests/cd/cd2a51a.ada | 193 ++++ gcc/testsuite/ada/acats/tests/cd/cd2a53a.ada | 217 +++++ gcc/testsuite/ada/acats/tests/cd/cd2a53e.ada | 235 +++++ gcc/testsuite/ada/acats/tests/cd/cd2a83c.tst | 101 ++ gcc/testsuite/ada/acats/tests/cd/cd2a91c.tst | 134 +++ gcc/testsuite/ada/acats/tests/cd/cd2b11a.ada | 214 +++++ gcc/testsuite/ada/acats/tests/cd/cd2b11b.ada | 196 ++++ gcc/testsuite/ada/acats/tests/cd/cd2b11d.ada | 54 ++ gcc/testsuite/ada/acats/tests/cd/cd2b11e.ada | 76 ++ gcc/testsuite/ada/acats/tests/cd/cd2b11f.ada | 88 ++ gcc/testsuite/ada/acats/tests/cd/cd2b15c.ada | 103 ++ gcc/testsuite/ada/acats/tests/cd/cd2b16a.ada | 85 ++ gcc/testsuite/ada/acats/tests/cd/cd2c11a.tst | 140 +++ gcc/testsuite/ada/acats/tests/cd/cd2c11d.tst | 87 ++ gcc/testsuite/ada/acats/tests/cd/cd2d11a.ada | 214 +++++ gcc/testsuite/ada/acats/tests/cd/cd2d13a.ada | 66 ++ gcc/testsuite/ada/acats/tests/cd/cd30001.a | 284 ++++++ gcc/testsuite/ada/acats/tests/cd/cd30002.a | 207 ++++ gcc/testsuite/ada/acats/tests/cd/cd30003.a | 227 +++++ gcc/testsuite/ada/acats/tests/cd/cd30004.a | 215 +++++ gcc/testsuite/ada/acats/tests/cd/cd300050.am | 154 +++ gcc/testsuite/ada/acats/tests/cd/cd300051.c | 57 ++ gcc/testsuite/ada/acats/tests/cd/cd3014a.ada | 132 +++ gcc/testsuite/ada/acats/tests/cd/cd3014c.ada | 85 ++ gcc/testsuite/ada/acats/tests/cd/cd3014d.ada | 135 +++ gcc/testsuite/ada/acats/tests/cd/cd3014f.ada | 88 ++ gcc/testsuite/ada/acats/tests/cd/cd3015a.ada | 133 +++ gcc/testsuite/ada/acats/tests/cd/cd3015c.ada | 82 ++ gcc/testsuite/ada/acats/tests/cd/cd3015e.ada | 130 +++ gcc/testsuite/ada/acats/tests/cd/cd3015f.ada | 93 ++ gcc/testsuite/ada/acats/tests/cd/cd3015g.ada | 136 +++ gcc/testsuite/ada/acats/tests/cd/cd3015h.ada | 86 ++ gcc/testsuite/ada/acats/tests/cd/cd3015i.ada | 144 +++ gcc/testsuite/ada/acats/tests/cd/cd3015k.ada | 92 ++ gcc/testsuite/ada/acats/tests/cd/cd3021a.ada | 66 ++ gcc/testsuite/ada/acats/tests/cd/cd33001.a | 139 +++ gcc/testsuite/ada/acats/tests/cd/cd33002.a | 140 +++ gcc/testsuite/ada/acats/tests/cd/cd40001.a | 181 ++++ gcc/testsuite/ada/acats/tests/cd/cd4031a.ada | 95 ++ gcc/testsuite/ada/acats/tests/cd/cd4041a.tst | 92 ++ gcc/testsuite/ada/acats/tests/cd/cd4051a.ada | 92 ++ gcc/testsuite/ada/acats/tests/cd/cd4051b.ada | 94 ++ gcc/testsuite/ada/acats/tests/cd/cd4051c.ada | 108 +++ gcc/testsuite/ada/acats/tests/cd/cd4051d.ada | 134 +++ gcc/testsuite/ada/acats/tests/cd/cd5003a.ada | 79 ++ gcc/testsuite/ada/acats/tests/cd/cd5003b.ada | 77 ++ gcc/testsuite/ada/acats/tests/cd/cd5003c.ada | 86 ++ gcc/testsuite/ada/acats/tests/cd/cd5003d.ada | 88 ++ gcc/testsuite/ada/acats/tests/cd/cd5003e.ada | 76 ++ gcc/testsuite/ada/acats/tests/cd/cd5003f.ada | 91 ++ gcc/testsuite/ada/acats/tests/cd/cd5003g.ada | 89 ++ gcc/testsuite/ada/acats/tests/cd/cd5003h.ada | 89 ++ gcc/testsuite/ada/acats/tests/cd/cd5003i.ada | 94 ++ gcc/testsuite/ada/acats/tests/cd/cd5011a.ada | 87 ++ gcc/testsuite/ada/acats/tests/cd/cd5011c.ada | 69 ++ gcc/testsuite/ada/acats/tests/cd/cd5011e.ada | 70 ++ gcc/testsuite/ada/acats/tests/cd/cd5011g.ada | 72 ++ gcc/testsuite/ada/acats/tests/cd/cd5011i.ada | 74 ++ gcc/testsuite/ada/acats/tests/cd/cd5011k.ada | 75 ++ gcc/testsuite/ada/acats/tests/cd/cd5011m.ada | 72 ++ gcc/testsuite/ada/acats/tests/cd/cd5011q.ada | 91 ++ gcc/testsuite/ada/acats/tests/cd/cd5011s.ada | 89 ++ gcc/testsuite/ada/acats/tests/cd/cd5012a.ada | 78 ++ gcc/testsuite/ada/acats/tests/cd/cd5012b.ada | 77 ++ gcc/testsuite/ada/acats/tests/cd/cd5012e.ada | 76 ++ gcc/testsuite/ada/acats/tests/cd/cd5012f.ada | 78 ++ gcc/testsuite/ada/acats/tests/cd/cd5012i.ada | 87 ++ gcc/testsuite/ada/acats/tests/cd/cd5012m.ada | 78 ++ gcc/testsuite/ada/acats/tests/cd/cd5013a.ada | 72 ++ gcc/testsuite/ada/acats/tests/cd/cd5013c.ada | 73 ++ gcc/testsuite/ada/acats/tests/cd/cd5013e.ada | 72 ++ gcc/testsuite/ada/acats/tests/cd/cd5013g.ada | 74 ++ gcc/testsuite/ada/acats/tests/cd/cd5013i.ada | 73 ++ gcc/testsuite/ada/acats/tests/cd/cd5013k.ada | 78 ++ gcc/testsuite/ada/acats/tests/cd/cd5013m.ada | 73 ++ gcc/testsuite/ada/acats/tests/cd/cd5013o.ada | 83 ++ gcc/testsuite/ada/acats/tests/cd/cd5014a.ada | 84 ++ gcc/testsuite/ada/acats/tests/cd/cd5014c.ada | 84 ++ gcc/testsuite/ada/acats/tests/cd/cd5014e.ada | 84 ++ gcc/testsuite/ada/acats/tests/cd/cd5014g.ada | 84 ++ gcc/testsuite/ada/acats/tests/cd/cd5014i.ada | 83 ++ gcc/testsuite/ada/acats/tests/cd/cd5014k.ada | 87 ++ gcc/testsuite/ada/acats/tests/cd/cd5014m.ada | 88 ++ gcc/testsuite/ada/acats/tests/cd/cd5014o.ada | 85 ++ gcc/testsuite/ada/acats/tests/cd/cd5014t.ada | 86 ++ gcc/testsuite/ada/acats/tests/cd/cd5014v.ada | 83 ++ gcc/testsuite/ada/acats/tests/cd/cd5014x.ada | 89 ++ gcc/testsuite/ada/acats/tests/cd/cd5014y.ada | 74 ++ gcc/testsuite/ada/acats/tests/cd/cd5014z.ada | 76 ++ gcc/testsuite/ada/acats/tests/cd/cd70001.a | 201 ++++ gcc/testsuite/ada/acats/tests/cd/cd7002a.ada | 52 + gcc/testsuite/ada/acats/tests/cd/cd7007b.ada | 52 + gcc/testsuite/ada/acats/tests/cd/cd7101d.ada | 53 ++ gcc/testsuite/ada/acats/tests/cd/cd7101e.dep | 62 ++ gcc/testsuite/ada/acats/tests/cd/cd7101f.dep | 62 ++ gcc/testsuite/ada/acats/tests/cd/cd7101g.tst | 70 ++ gcc/testsuite/ada/acats/tests/cd/cd7103d.ada | 52 + gcc/testsuite/ada/acats/tests/cd/cd7202a.ada | 55 ++ gcc/testsuite/ada/acats/tests/cd/cd7204b.ada | 88 ++ gcc/testsuite/ada/acats/tests/cd/cd7204c.ada | 91 ++ gcc/testsuite/ada/acats/tests/cd/cd72a01.a | 165 ++++ gcc/testsuite/ada/acats/tests/cd/cd72a02.a | 225 +++++ gcc/testsuite/ada/acats/tests/cd/cd7305a.ada | 52 + gcc/testsuite/ada/acats/tests/cd/cd90001.a | 233 +++++ gcc/testsuite/ada/acats/tests/cd/cd92001.a | 229 +++++ gcc/testsuite/ada/acats/tests/cd/cda201a.ada | 70 ++ gcc/testsuite/ada/acats/tests/cd/cda201b.ada | 63 ++ gcc/testsuite/ada/acats/tests/cd/cda201c.ada | 76 ++ gcc/testsuite/ada/acats/tests/cd/cda201e.ada | 120 +++ gcc/testsuite/ada/acats/tests/cd/cdb0a01.a | 305 ++++++ gcc/testsuite/ada/acats/tests/cd/cdb0a02.a | 329 +++++++ gcc/testsuite/ada/acats/tests/cd/cdd1001.a | 94 ++ gcc/testsuite/ada/acats/tests/cd/cdd2001.a | 203 ++++ gcc/testsuite/ada/acats/tests/cd/cdd2a01.a | 379 ++++++++ gcc/testsuite/ada/acats/tests/cd/cdd2a02.a | 345 +++++++ gcc/testsuite/ada/acats/tests/cd/cdd2a03.a | 325 +++++++ gcc/testsuite/ada/acats/tests/cd/cde0001.a | 324 +++++++ gcc/testsuite/ada/acats/tests/ce/ce2102a.ada | 133 +++ gcc/testsuite/ada/acats/tests/ce/ce2102b.ada | 155 +++ gcc/testsuite/ada/acats/tests/ce/ce2102c.tst | 140 +++ gcc/testsuite/ada/acats/tests/ce/ce2102d.ada | 63 ++ gcc/testsuite/ada/acats/tests/ce/ce2102e.ada | 66 ++ gcc/testsuite/ada/acats/tests/ce/ce2102f.ada | 65 ++ gcc/testsuite/ada/acats/tests/ce/ce2102g.ada | 130 +++ gcc/testsuite/ada/acats/tests/ce/ce2102h.tst | 136 +++ gcc/testsuite/ada/acats/tests/ce/ce2102i.ada | 63 ++ gcc/testsuite/ada/acats/tests/ce/ce2102j.ada | 66 ++ gcc/testsuite/ada/acats/tests/ce/ce2102k.ada | 248 +++++ gcc/testsuite/ada/acats/tests/ce/ce2102l.ada | 147 +++ gcc/testsuite/ada/acats/tests/ce/ce2102m.ada | 146 +++ gcc/testsuite/ada/acats/tests/ce/ce2102n.ada | 98 ++ gcc/testsuite/ada/acats/tests/ce/ce2102o.ada | 117 +++ gcc/testsuite/ada/acats/tests/ce/ce2102p.ada | 98 ++ gcc/testsuite/ada/acats/tests/ce/ce2102q.ada | 97 ++ gcc/testsuite/ada/acats/tests/ce/ce2102r.ada | 98 ++ gcc/testsuite/ada/acats/tests/ce/ce2102s.ada | 98 ++ gcc/testsuite/ada/acats/tests/ce/ce2102t.ada | 98 ++ gcc/testsuite/ada/acats/tests/ce/ce2102u.ada | 117 +++ gcc/testsuite/ada/acats/tests/ce/ce2102v.ada | 98 ++ gcc/testsuite/ada/acats/tests/ce/ce2102w.ada | 98 ++ gcc/testsuite/ada/acats/tests/ce/ce2102x.ada | 85 ++ gcc/testsuite/ada/acats/tests/ce/ce2102y.ada | 83 ++ gcc/testsuite/ada/acats/tests/ce/ce2103a.tst | 142 +++ gcc/testsuite/ada/acats/tests/ce/ce2103b.tst | 141 +++ gcc/testsuite/ada/acats/tests/ce/ce2103c.ada | 149 +++ gcc/testsuite/ada/acats/tests/ce/ce2103d.ada | 148 +++ gcc/testsuite/ada/acats/tests/ce/ce2104a.ada | 118 +++ gcc/testsuite/ada/acats/tests/ce/ce2104b.ada | 125 +++ gcc/testsuite/ada/acats/tests/ce/ce2104c.ada | 115 +++ gcc/testsuite/ada/acats/tests/ce/ce2104d.ada | 126 +++ gcc/testsuite/ada/acats/tests/ce/ce2106a.ada | 122 +++ gcc/testsuite/ada/acats/tests/ce/ce2106b.ada | 119 +++ gcc/testsuite/ada/acats/tests/ce/ce2108e.ada | 83 ++ gcc/testsuite/ada/acats/tests/ce/ce2108f.ada | 112 +++ gcc/testsuite/ada/acats/tests/ce/ce2108g.ada | 82 ++ gcc/testsuite/ada/acats/tests/ce/ce2108h.ada | 108 +++ gcc/testsuite/ada/acats/tests/ce/ce2109a.ada | 83 ++ gcc/testsuite/ada/acats/tests/ce/ce2109b.ada | 80 ++ gcc/testsuite/ada/acats/tests/ce/ce2109c.ada | 76 ++ gcc/testsuite/ada/acats/tests/ce/ce2110a.ada | 104 ++ gcc/testsuite/ada/acats/tests/ce/ce2110c.ada | 104 ++ gcc/testsuite/ada/acats/tests/ce/ce2111a.ada | 131 +++ gcc/testsuite/ada/acats/tests/ce/ce2111b.ada | 183 ++++ gcc/testsuite/ada/acats/tests/ce/ce2111c.ada | 127 +++ gcc/testsuite/ada/acats/tests/ce/ce2111e.ada | 156 +++ gcc/testsuite/ada/acats/tests/ce/ce2111f.ada | 132 +++ gcc/testsuite/ada/acats/tests/ce/ce2111g.ada | 147 +++ gcc/testsuite/ada/acats/tests/ce/ce2111i.ada | 113 +++ gcc/testsuite/ada/acats/tests/ce/ce2201a.ada | 112 +++ gcc/testsuite/ada/acats/tests/ce/ce2201b.ada | 116 +++ gcc/testsuite/ada/acats/tests/ce/ce2201c.ada | 111 +++ gcc/testsuite/ada/acats/tests/ce/ce2201d.dep | 145 +++ gcc/testsuite/ada/acats/tests/ce/ce2201e.dep | 155 +++ gcc/testsuite/ada/acats/tests/ce/ce2201f.ada | 129 +++ gcc/testsuite/ada/acats/tests/ce/ce2201g.ada | 138 +++ gcc/testsuite/ada/acats/tests/ce/ce2201h.ada | 105 +++ gcc/testsuite/ada/acats/tests/ce/ce2201i.ada | 105 +++ gcc/testsuite/ada/acats/tests/ce/ce2201j.ada | 106 +++ gcc/testsuite/ada/acats/tests/ce/ce2201k.ada | 102 ++ gcc/testsuite/ada/acats/tests/ce/ce2201l.ada | 103 ++ gcc/testsuite/ada/acats/tests/ce/ce2201m.ada | 123 +++ gcc/testsuite/ada/acats/tests/ce/ce2201n.ada | 123 +++ gcc/testsuite/ada/acats/tests/ce/ce2202a.ada | 143 +++ gcc/testsuite/ada/acats/tests/ce/ce2203a.tst | 121 +++ gcc/testsuite/ada/acats/tests/ce/ce2204a.ada | 117 +++ gcc/testsuite/ada/acats/tests/ce/ce2204b.ada | 118 +++ gcc/testsuite/ada/acats/tests/ce/ce2204c.ada | 91 ++ gcc/testsuite/ada/acats/tests/ce/ce2204d.ada | 104 ++ gcc/testsuite/ada/acats/tests/ce/ce2205a.ada | 151 +++ gcc/testsuite/ada/acats/tests/ce/ce2206a.ada | 133 +++ gcc/testsuite/ada/acats/tests/ce/ce2208b.ada | 185 ++++ gcc/testsuite/ada/acats/tests/ce/ce2401a.ada | 357 +++++++ gcc/testsuite/ada/acats/tests/ce/ce2401b.ada | 347 +++++++ gcc/testsuite/ada/acats/tests/ce/ce2401c.ada | 268 ++++++ gcc/testsuite/ada/acats/tests/ce/ce2401e.ada | 172 ++++ gcc/testsuite/ada/acats/tests/ce/ce2401f.ada | 200 ++++ gcc/testsuite/ada/acats/tests/ce/ce2401h.ada | 168 ++++ gcc/testsuite/ada/acats/tests/ce/ce2401i.ada | 163 ++++ gcc/testsuite/ada/acats/tests/ce/ce2401j.ada | 176 ++++ gcc/testsuite/ada/acats/tests/ce/ce2401k.ada | 164 ++++ gcc/testsuite/ada/acats/tests/ce/ce2401l.ada | 125 +++ gcc/testsuite/ada/acats/tests/ce/ce2402a.ada | 161 ++++ gcc/testsuite/ada/acats/tests/ce/ce2403a.tst | 121 +++ gcc/testsuite/ada/acats/tests/ce/ce2404a.ada | 99 ++ gcc/testsuite/ada/acats/tests/ce/ce2404b.ada | 82 ++ gcc/testsuite/ada/acats/tests/ce/ce2405b.ada | 157 ++++ gcc/testsuite/ada/acats/tests/ce/ce2406a.ada | 199 ++++ gcc/testsuite/ada/acats/tests/ce/ce2407a.ada | 110 +++ gcc/testsuite/ada/acats/tests/ce/ce2407b.ada | 93 ++ gcc/testsuite/ada/acats/tests/ce/ce2408a.ada | 120 +++ gcc/testsuite/ada/acats/tests/ce/ce2408b.ada | 112 +++ gcc/testsuite/ada/acats/tests/ce/ce2409a.ada | 113 +++ gcc/testsuite/ada/acats/tests/ce/ce2409b.ada | 98 ++ gcc/testsuite/ada/acats/tests/ce/ce2410a.ada | 96 ++ gcc/testsuite/ada/acats/tests/ce/ce2410b.ada | 84 ++ gcc/testsuite/ada/acats/tests/ce/ce2411a.ada | 207 ++++ gcc/testsuite/ada/acats/tests/ce/ce3002b.tst | 84 ++ gcc/testsuite/ada/acats/tests/ce/ce3002c.tst | 69 ++ gcc/testsuite/ada/acats/tests/ce/ce3002d.ada | 61 ++ gcc/testsuite/ada/acats/tests/ce/ce3002f.ada | 55 ++ gcc/testsuite/ada/acats/tests/ce/ce3102a.ada | 151 +++ gcc/testsuite/ada/acats/tests/ce/ce3102b.tst | 184 ++++ gcc/testsuite/ada/acats/tests/ce/ce3102d.ada | 145 +++ gcc/testsuite/ada/acats/tests/ce/ce3102e.ada | 63 ++ gcc/testsuite/ada/acats/tests/ce/ce3102f.ada | 130 +++ gcc/testsuite/ada/acats/tests/ce/ce3102g.ada | 84 ++ gcc/testsuite/ada/acats/tests/ce/ce3102h.ada | 116 +++ gcc/testsuite/ada/acats/tests/ce/ce3102i.ada | 63 ++ gcc/testsuite/ada/acats/tests/ce/ce3102j.ada | 98 ++ gcc/testsuite/ada/acats/tests/ce/ce3102k.ada | 98 ++ gcc/testsuite/ada/acats/tests/ce/ce3103a.ada | 216 +++++ gcc/testsuite/ada/acats/tests/ce/ce3104a.ada | 231 +++++ gcc/testsuite/ada/acats/tests/ce/ce3104b.ada | 120 +++ gcc/testsuite/ada/acats/tests/ce/ce3104c.ada | 117 +++ gcc/testsuite/ada/acats/tests/ce/ce3106a.ada | 226 +++++ gcc/testsuite/ada/acats/tests/ce/ce3106b.ada | 220 +++++ gcc/testsuite/ada/acats/tests/ce/ce3107a.tst | 135 +++ gcc/testsuite/ada/acats/tests/ce/ce3107b.ada | 141 +++ gcc/testsuite/ada/acats/tests/ce/ce3108a.ada | 106 +++ gcc/testsuite/ada/acats/tests/ce/ce3108b.ada | 111 +++ gcc/testsuite/ada/acats/tests/ce/ce3110a.ada | 107 +++ gcc/testsuite/ada/acats/tests/ce/ce3112c.ada | 81 ++ gcc/testsuite/ada/acats/tests/ce/ce3112d.ada | 112 +++ gcc/testsuite/ada/acats/tests/ce/ce3114a.ada | 102 ++ gcc/testsuite/ada/acats/tests/ce/ce3115a.ada | 232 +++++ gcc/testsuite/ada/acats/tests/ce/ce3201a.ada | 71 ++ gcc/testsuite/ada/acats/tests/ce/ce3202a.ada | 57 ++ gcc/testsuite/ada/acats/tests/ce/ce3206a.ada | 103 ++ gcc/testsuite/ada/acats/tests/ce/ce3207a.ada | 107 +++ gcc/testsuite/ada/acats/tests/ce/ce3301a.ada | 176 ++++ gcc/testsuite/ada/acats/tests/ce/ce3302a.ada | 138 +++ gcc/testsuite/ada/acats/tests/ce/ce3303a.ada | 152 +++ gcc/testsuite/ada/acats/tests/ce/ce3304a.tst | 204 ++++ gcc/testsuite/ada/acats/tests/ce/ce3305a.ada | 182 ++++ gcc/testsuite/ada/acats/tests/ce/ce3306a.ada | 82 ++ gcc/testsuite/ada/acats/tests/ce/ce3401a.ada | 105 +++ gcc/testsuite/ada/acats/tests/ce/ce3402a.ada | 117 +++ gcc/testsuite/ada/acats/tests/ce/ce3402c.ada | 112 +++ gcc/testsuite/ada/acats/tests/ce/ce3402d.ada | 92 ++ gcc/testsuite/ada/acats/tests/ce/ce3402e.ada | 106 +++ gcc/testsuite/ada/acats/tests/ce/ce3403a.ada | 109 +++ gcc/testsuite/ada/acats/tests/ce/ce3403b.ada | 152 +++ gcc/testsuite/ada/acats/tests/ce/ce3403c.ada | 122 +++ gcc/testsuite/ada/acats/tests/ce/ce3403d.ada | 99 ++ gcc/testsuite/ada/acats/tests/ce/ce3403e.ada | 150 +++ gcc/testsuite/ada/acats/tests/ce/ce3403f.ada | 156 +++ gcc/testsuite/ada/acats/tests/ce/ce3404a.ada | 94 ++ gcc/testsuite/ada/acats/tests/ce/ce3404b.ada | 130 +++ gcc/testsuite/ada/acats/tests/ce/ce3404c.ada | 165 ++++ gcc/testsuite/ada/acats/tests/ce/ce3404d.ada | 152 +++ gcc/testsuite/ada/acats/tests/ce/ce3405a.ada | 127 +++ gcc/testsuite/ada/acats/tests/ce/ce3405c.ada | 126 +++ gcc/testsuite/ada/acats/tests/ce/ce3405d.ada | 114 +++ gcc/testsuite/ada/acats/tests/ce/ce3406a.ada | 159 ++++ gcc/testsuite/ada/acats/tests/ce/ce3406b.ada | 104 ++ gcc/testsuite/ada/acats/tests/ce/ce3406c.ada | 148 +++ gcc/testsuite/ada/acats/tests/ce/ce3406d.ada | 122 +++ gcc/testsuite/ada/acats/tests/ce/ce3407a.ada | 141 +++ gcc/testsuite/ada/acats/tests/ce/ce3407b.ada | 107 +++ gcc/testsuite/ada/acats/tests/ce/ce3407c.ada | 134 +++ gcc/testsuite/ada/acats/tests/ce/ce3408a.ada | 142 +++ gcc/testsuite/ada/acats/tests/ce/ce3408b.ada | 109 +++ gcc/testsuite/ada/acats/tests/ce/ce3408c.ada | 138 +++ gcc/testsuite/ada/acats/tests/ce/ce3409a.ada | 111 +++ gcc/testsuite/ada/acats/tests/ce/ce3409b.ada | 76 ++ gcc/testsuite/ada/acats/tests/ce/ce3409c.ada | 188 ++++ gcc/testsuite/ada/acats/tests/ce/ce3409d.ada | 140 +++ gcc/testsuite/ada/acats/tests/ce/ce3409e.ada | 115 +++ gcc/testsuite/ada/acats/tests/ce/ce3410a.ada | 89 ++ gcc/testsuite/ada/acats/tests/ce/ce3410b.ada | 77 ++ gcc/testsuite/ada/acats/tests/ce/ce3410c.ada | 205 ++++ gcc/testsuite/ada/acats/tests/ce/ce3410d.ada | 118 +++ gcc/testsuite/ada/acats/tests/ce/ce3410e.ada | 125 +++ gcc/testsuite/ada/acats/tests/ce/ce3411a.ada | 164 ++++ gcc/testsuite/ada/acats/tests/ce/ce3411c.ada | 146 +++ gcc/testsuite/ada/acats/tests/ce/ce3412a.ada | 149 +++ gcc/testsuite/ada/acats/tests/ce/ce3413a.ada | 128 +++ gcc/testsuite/ada/acats/tests/ce/ce3413b.ada | 163 ++++ gcc/testsuite/ada/acats/tests/ce/ce3413c.ada | 152 +++ gcc/testsuite/ada/acats/tests/ce/ce3414a.ada | 204 ++++ gcc/testsuite/ada/acats/tests/ce/ce3601a.ada | 187 ++++ gcc/testsuite/ada/acats/tests/ce/ce3602a.ada | 189 ++++ gcc/testsuite/ada/acats/tests/ce/ce3602b.ada | 215 +++++ gcc/testsuite/ada/acats/tests/ce/ce3602c.ada | 202 ++++ gcc/testsuite/ada/acats/tests/ce/ce3602d.ada | 150 +++ gcc/testsuite/ada/acats/tests/ce/ce3603a.ada | 217 +++++ gcc/testsuite/ada/acats/tests/ce/ce3604a.ada | 160 ++++ gcc/testsuite/ada/acats/tests/ce/ce3604b.ada | 137 +++ gcc/testsuite/ada/acats/tests/ce/ce3605a.ada | 118 +++ gcc/testsuite/ada/acats/tests/ce/ce3605b.ada | 142 +++ gcc/testsuite/ada/acats/tests/ce/ce3605c.ada | 159 ++++ gcc/testsuite/ada/acats/tests/ce/ce3605d.ada | 192 ++++ gcc/testsuite/ada/acats/tests/ce/ce3605e.ada | 103 ++ gcc/testsuite/ada/acats/tests/ce/ce3606a.ada | 91 ++ gcc/testsuite/ada/acats/tests/ce/ce3606b.ada | 97 ++ gcc/testsuite/ada/acats/tests/ce/ce3701a.ada | 109 +++ gcc/testsuite/ada/acats/tests/ce/ce3704a.ada | 134 +++ gcc/testsuite/ada/acats/tests/ce/ce3704b.ada | 107 +++ gcc/testsuite/ada/acats/tests/ce/ce3704c.ada | 176 ++++ gcc/testsuite/ada/acats/tests/ce/ce3704d.ada | 169 ++++ gcc/testsuite/ada/acats/tests/ce/ce3704e.ada | 143 +++ gcc/testsuite/ada/acats/tests/ce/ce3704f.ada | 365 ++++++++ gcc/testsuite/ada/acats/tests/ce/ce3704m.ada | 198 ++++ gcc/testsuite/ada/acats/tests/ce/ce3704n.ada | 229 +++++ gcc/testsuite/ada/acats/tests/ce/ce3704o.ada | 161 ++++ gcc/testsuite/ada/acats/tests/ce/ce3705a.ada | 109 +++ gcc/testsuite/ada/acats/tests/ce/ce3705b.ada | 144 +++ gcc/testsuite/ada/acats/tests/ce/ce3705c.ada | 137 +++ gcc/testsuite/ada/acats/tests/ce/ce3705d.ada | 124 +++ gcc/testsuite/ada/acats/tests/ce/ce3705e.ada | 124 +++ gcc/testsuite/ada/acats/tests/ce/ce3706c.ada | 164 ++++ gcc/testsuite/ada/acats/tests/ce/ce3706d.ada | 127 +++ gcc/testsuite/ada/acats/tests/ce/ce3706f.ada | 119 +++ gcc/testsuite/ada/acats/tests/ce/ce3706g.ada | 111 +++ gcc/testsuite/ada/acats/tests/ce/ce3707a.ada | 130 +++ gcc/testsuite/ada/acats/tests/ce/ce3708a.ada | 87 ++ gcc/testsuite/ada/acats/tests/ce/ce3801a.ada | 112 +++ gcc/testsuite/ada/acats/tests/ce/ce3801b.ada | 108 +++ gcc/testsuite/ada/acats/tests/ce/ce3804a.ada | 157 ++++ gcc/testsuite/ada/acats/tests/ce/ce3804b.ada | 147 +++ gcc/testsuite/ada/acats/tests/ce/ce3804c.ada | 121 +++ gcc/testsuite/ada/acats/tests/ce/ce3804d.ada | 153 +++ gcc/testsuite/ada/acats/tests/ce/ce3804e.ada | 154 +++ gcc/testsuite/ada/acats/tests/ce/ce3804f.ada | 206 ++++ gcc/testsuite/ada/acats/tests/ce/ce3804g.ada | 167 ++++ gcc/testsuite/ada/acats/tests/ce/ce3804h.ada | 161 ++++ gcc/testsuite/ada/acats/tests/ce/ce3804i.ada | 141 +++ gcc/testsuite/ada/acats/tests/ce/ce3804j.ada | 137 +++ gcc/testsuite/ada/acats/tests/ce/ce3804m.ada | 157 ++++ gcc/testsuite/ada/acats/tests/ce/ce3804o.ada | 121 +++ gcc/testsuite/ada/acats/tests/ce/ce3804p.ada | 206 ++++ gcc/testsuite/ada/acats/tests/ce/ce3805a.ada | 162 ++++ gcc/testsuite/ada/acats/tests/ce/ce3805b.ada | 163 ++++ gcc/testsuite/ada/acats/tests/ce/ce3806a.ada | 132 +++ gcc/testsuite/ada/acats/tests/ce/ce3806b.ada | 124 +++ gcc/testsuite/ada/acats/tests/ce/ce3806c.ada | 197 ++++ gcc/testsuite/ada/acats/tests/ce/ce3806d.ada | 129 +++ gcc/testsuite/ada/acats/tests/ce/ce3806e.ada | 159 ++++ gcc/testsuite/ada/acats/tests/ce/ce3806f.ada | 194 ++++ gcc/testsuite/ada/acats/tests/ce/ce3806g.ada | 125 +++ gcc/testsuite/ada/acats/tests/ce/ce3806h.ada | 144 +++ gcc/testsuite/ada/acats/tests/ce/ce3809a.ada | 239 +++++ gcc/testsuite/ada/acats/tests/ce/ce3809b.ada | 239 +++++ gcc/testsuite/ada/acats/tests/ce/ce3810a.ada | 114 +++ gcc/testsuite/ada/acats/tests/ce/ce3810b.ada | 122 +++ gcc/testsuite/ada/acats/tests/ce/ce3815a.ada | 103 ++ gcc/testsuite/ada/acats/tests/ce/ce3901a.ada | 106 +++ gcc/testsuite/ada/acats/tests/ce/ce3902b.ada | 117 +++ gcc/testsuite/ada/acats/tests/ce/ce3904a.ada | 117 +++ gcc/testsuite/ada/acats/tests/ce/ce3904b.ada | 142 +++ gcc/testsuite/ada/acats/tests/ce/ce3905a.ada | 145 +++ gcc/testsuite/ada/acats/tests/ce/ce3905b.ada | 111 +++ gcc/testsuite/ada/acats/tests/ce/ce3905c.ada | 202 ++++ gcc/testsuite/ada/acats/tests/ce/ce3905l.ada | 311 ++++++ gcc/testsuite/ada/acats/tests/ce/ce3906a.ada | 110 +++ gcc/testsuite/ada/acats/tests/ce/ce3906b.ada | 133 +++ gcc/testsuite/ada/acats/tests/ce/ce3906c.ada | 177 ++++ gcc/testsuite/ada/acats/tests/ce/ce3906d.ada | 152 +++ gcc/testsuite/ada/acats/tests/ce/ce3906e.ada | 109 +++ gcc/testsuite/ada/acats/tests/ce/ce3906f.ada | 102 ++ gcc/testsuite/ada/acats/tests/ce/ce3907a.ada | 75 ++ gcc/testsuite/ada/acats/tests/ce/ce3908a.ada | 140 +++ gcc/testsuite/ada/acats/tests/cxa/cxa3001.a | 507 ++++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa3002.a | 318 +++++++ gcc/testsuite/ada/acats/tests/cxa/cxa3003.a | 243 +++++ gcc/testsuite/ada/acats/tests/cxa/cxa4001.a | 218 +++++ gcc/testsuite/ada/acats/tests/cxa/cxa4002.a | 182 ++++ gcc/testsuite/ada/acats/tests/cxa/cxa4003.a | 326 +++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4004.a | 431 +++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4005.a | 683 ++++++++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4006.a | 319 +++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4007.a | 334 +++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4008.a | 662 +++++++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4009.a | 619 ++++++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4010.a | 275 ++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4011.a | 376 ++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4012.a | 305 ++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4013.a | 203 ++++ gcc/testsuite/ada/acats/tests/cxa/cxa4014.a | 359 +++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4015.a | 580 ++++++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4016.a | 685 ++++++++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4017.a | 337 +++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4018.a | 379 ++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4019.a | 1027 ++++++++++++++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4020.a | 688 ++++++++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4021.a | 311 ++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4022.a | 531 +++++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4023.a | 585 ++++++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4024.a | 350 +++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4025.a | 376 ++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4026.a | 526 +++++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4027.a | 342 +++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4028.a | 331 +++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4029.a | 333 +++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4030.a | 414 ++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4031.a | 291 ++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4032.a | 457 +++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4033.a | 405 ++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa4034.a | 281 ++++++ gcc/testsuite/ada/acats/tests/cxa/cxa5011.a | 471 ++++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa5012.a | 536 +++++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa5015.a | 342 +++++++ gcc/testsuite/ada/acats/tests/cxa/cxa5a01.a | 338 +++++++ gcc/testsuite/ada/acats/tests/cxa/cxa5a02.a | 328 +++++++ gcc/testsuite/ada/acats/tests/cxa/cxa5a03.a | 426 +++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa5a04.a | 434 +++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa5a05.a | 338 +++++++ gcc/testsuite/ada/acats/tests/cxa/cxa5a06.a | 334 +++++++ gcc/testsuite/ada/acats/tests/cxa/cxa5a07.a | 413 ++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa5a08.a | 474 ++++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa5a09.a | 400 ++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa5a10.a | 551 +++++++++++ gcc/testsuite/ada/acats/tests/cxa/cxa8001.a | 243 +++++ gcc/testsuite/ada/acats/tests/cxa/cxa8002.a | 285 ++++++ gcc/testsuite/ada/acats/tests/cxa/cxa8003.a | 214 +++++ gcc/testsuite/ada/acats/tests/cxa/cxa9001.a | 287 ++++++ gcc/testsuite/ada/acats/tests/cxa/cxa9002.a | 482 ++++++++++ gcc/testsuite/ada/acats/tests/cxa/cxaa001.a | 279 ++++++ gcc/testsuite/ada/acats/tests/cxa/cxaa002.a | 257 +++++ gcc/testsuite/ada/acats/tests/cxa/cxaa003.a | 293 ++++++ gcc/testsuite/ada/acats/tests/cxa/cxaa004.a | 260 +++++ gcc/testsuite/ada/acats/tests/cxa/cxaa005.a | 292 ++++++ gcc/testsuite/ada/acats/tests/cxa/cxaa006.a | 285 ++++++ gcc/testsuite/ada/acats/tests/cxa/cxaa007.a | 263 ++++++ gcc/testsuite/ada/acats/tests/cxa/cxaa008.a | 271 ++++++ gcc/testsuite/ada/acats/tests/cxa/cxaa009.a | 290 ++++++ gcc/testsuite/ada/acats/tests/cxa/cxaa010.a | 335 +++++++ gcc/testsuite/ada/acats/tests/cxa/cxaa011.a | 266 ++++++ gcc/testsuite/ada/acats/tests/cxa/cxaa012.a | 167 ++++ gcc/testsuite/ada/acats/tests/cxa/cxaa013.a | 167 ++++ gcc/testsuite/ada/acats/tests/cxa/cxaa014.a | 178 ++++ gcc/testsuite/ada/acats/tests/cxa/cxaa015.a | 227 +++++ gcc/testsuite/ada/acats/tests/cxa/cxaa016.a | 462 +++++++++ gcc/testsuite/ada/acats/tests/cxa/cxaa017.a | 400 ++++++++ gcc/testsuite/ada/acats/tests/cxa/cxaa018.a | 277 ++++++ gcc/testsuite/ada/acats/tests/cxa/cxaa019.a | 138 +++ gcc/testsuite/ada/acats/tests/cxa/cxab001.a | 272 ++++++ gcc/testsuite/ada/acats/tests/cxa/cxac001.a | 292 ++++++ gcc/testsuite/ada/acats/tests/cxa/cxac002.a | 426 +++++++++ gcc/testsuite/ada/acats/tests/cxa/cxac003.a | 376 ++++++++ gcc/testsuite/ada/acats/tests/cxa/cxac004.a | 310 ++++++ gcc/testsuite/ada/acats/tests/cxa/cxac005.a | 343 +++++++ gcc/testsuite/ada/acats/tests/cxa/cxaca01.a | 291 ++++++ gcc/testsuite/ada/acats/tests/cxa/cxaca02.a | 360 +++++++ gcc/testsuite/ada/acats/tests/cxa/cxacb01.a | 264 ++++++ gcc/testsuite/ada/acats/tests/cxa/cxacb02.a | 421 +++++++++ gcc/testsuite/ada/acats/tests/cxa/cxacc01.a | 299 ++++++ gcc/testsuite/ada/acats/tests/cxa/cxaf001.a | 199 ++++ gcc/testsuite/ada/acats/tests/cxb/cxb2001.a | 633 +++++++++++++ gcc/testsuite/ada/acats/tests/cxb/cxb2002.a | 259 +++++ gcc/testsuite/ada/acats/tests/cxb/cxb2003.a | 255 +++++ gcc/testsuite/ada/acats/tests/cxb/cxb3001.a | 179 ++++ gcc/testsuite/ada/acats/tests/cxb/cxb3002.a | 158 ++++ gcc/testsuite/ada/acats/tests/cxb/cxb3003.a | 167 ++++ gcc/testsuite/ada/acats/tests/cxb/cxb30040.c | 172 ++++ gcc/testsuite/ada/acats/tests/cxb/cxb30041.am | 377 ++++++++ gcc/testsuite/ada/acats/tests/cxb/cxb3005.a | 396 ++++++++ gcc/testsuite/ada/acats/tests/cxb/cxb30060.c | 174 ++++ gcc/testsuite/ada/acats/tests/cxb/cxb3007.a | 408 ++++++++ gcc/testsuite/ada/acats/tests/cxb/cxb3008.a | 226 +++++ gcc/testsuite/ada/acats/tests/cxb/cxb3009.a | 305 ++++++ gcc/testsuite/ada/acats/tests/cxb/cxb3010.a | 320 +++++++ gcc/testsuite/ada/acats/tests/cxb/cxb3011.a | 282 ++++++ gcc/testsuite/ada/acats/tests/cxb/cxb3012.a | 392 ++++++++ gcc/testsuite/ada/acats/tests/cxb/cxb30130.c | 86 ++ gcc/testsuite/ada/acats/tests/cxb/cxb30131.c | 104 ++ gcc/testsuite/ada/acats/tests/cxb/cxb30132.am | 205 ++++ gcc/testsuite/ada/acats/tests/cxb/cxb3014.a | 254 +++++ gcc/testsuite/ada/acats/tests/cxb/cxb3015.a | 520 ++++++++++ gcc/testsuite/ada/acats/tests/cxb/cxb3016.a | 516 ++++++++++ gcc/testsuite/ada/acats/tests/cxb/cxb4001.a | 230 +++++ gcc/testsuite/ada/acats/tests/cxb/cxb4002.a | 308 ++++++ gcc/testsuite/ada/acats/tests/cxb/cxb4003.a | 310 ++++++ gcc/testsuite/ada/acats/tests/cxb/cxb4004.a | 443 +++++++++ gcc/testsuite/ada/acats/tests/cxb/cxb4005.a | 332 +++++++ gcc/testsuite/ada/acats/tests/cxb/cxb4006.a | 322 +++++++ gcc/testsuite/ada/acats/tests/cxb/cxb4007.a | 271 ++++++ gcc/testsuite/ada/acats/tests/cxb/cxb4008.a | 248 +++++ gcc/testsuite/ada/acats/tests/cxb/cxb5001.a | 110 +++ gcc/testsuite/ada/acats/tests/cxb/cxb5002.a | 334 +++++++ gcc/testsuite/ada/acats/tests/cxb/cxb5003.a | 295 ++++++ gcc/testsuite/ada/acats/tests/cxf/cxf1001.a | 261 ++++++ gcc/testsuite/ada/acats/tests/cxf/cxf2001.a | 755 +++++++++++++++ gcc/testsuite/ada/acats/tests/cxf/cxf2002.a | 352 +++++++ gcc/testsuite/ada/acats/tests/cxf/cxf2003.a | 363 +++++++ gcc/testsuite/ada/acats/tests/cxf/cxf2004.a | 513 ++++++++++ gcc/testsuite/ada/acats/tests/cxf/cxf2005.a | 293 ++++++ gcc/testsuite/ada/acats/tests/cxf/cxf2a01.a | 448 +++++++++ gcc/testsuite/ada/acats/tests/cxf/cxf2a02.a | 354 +++++++ gcc/testsuite/ada/acats/tests/cxf/cxf3001.a | 192 ++++ gcc/testsuite/ada/acats/tests/cxf/cxf3002.a | 231 +++++ gcc/testsuite/ada/acats/tests/cxf/cxf3003.a | 292 ++++++ gcc/testsuite/ada/acats/tests/cxf/cxf3004.a | 257 +++++ gcc/testsuite/ada/acats/tests/cxf/cxf3a01.a | 167 ++++ gcc/testsuite/ada/acats/tests/cxf/cxf3a02.a | 267 ++++++ gcc/testsuite/ada/acats/tests/cxf/cxf3a03.a | 429 +++++++++ gcc/testsuite/ada/acats/tests/cxf/cxf3a04.a | 293 ++++++ gcc/testsuite/ada/acats/tests/cxf/cxf3a05.a | 266 ++++++ gcc/testsuite/ada/acats/tests/cxf/cxf3a06.a | 302 ++++++ gcc/testsuite/ada/acats/tests/cxf/cxf3a07.a | 337 +++++++ gcc/testsuite/ada/acats/tests/cxf/cxf3a08.a | 289 ++++++ gcc/testsuite/ada/acats/tests/cxg/cxg1001.a | 276 ++++++ gcc/testsuite/ada/acats/tests/cxg/cxg1002.a | 198 ++++ gcc/testsuite/ada/acats/tests/cxg/cxg1003.a | 478 ++++++++++ gcc/testsuite/ada/acats/tests/cxg/cxg1004.a | 360 +++++++ gcc/testsuite/ada/acats/tests/cxg/cxg1005.a | 393 ++++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2001.a | 322 +++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2002.a | 468 +++++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2003.a | 701 ++++++++++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2004.a | 499 ++++++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2005.a | 204 ++++ gcc/testsuite/ada/acats/tests/cxg/cxg2006.a | 281 ++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2007.a | 291 ++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2008.a | 948 +++++++++++++++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2009.a | 421 +++++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2010.a | 892 ++++++++++++++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2011.a | 490 ++++++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2012.a | 438 +++++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2013.a | 367 ++++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2014.a | 399 ++++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2015.a | 686 ++++++++++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2016.a | 482 ++++++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2017.a | 296 ++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2018.a | 355 +++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2019.a | 338 +++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2020.a | 351 +++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2021.a | 386 ++++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2022.a | 309 ++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2023.a | 351 +++++++ gcc/testsuite/ada/acats/tests/cxg/cxg2024.a | 191 ++++ gcc/testsuite/ada/acats/tests/cxh/cxh1001.a | 349 +++++++ gcc/testsuite/ada/acats/tests/cxh/cxh3001.a | 243 +++++ gcc/testsuite/ada/acats/tests/cxh/cxh3002.a | 343 +++++++ gcc/testsuite/ada/acats/tests/cxh/cxh30030.a | 54 ++ gcc/testsuite/ada/acats/tests/cxh/cxh30031.am | 215 +++++ gcc/testsuite/ada/acats/tests/cz/cz1101a.ada | 111 +++ gcc/testsuite/ada/acats/tests/cz/cz1102a.ada | 75 ++ gcc/testsuite/ada/acats/tests/cz/cz1103a.ada | 232 +++++ gcc/testsuite/ada/acats/tests/d/d4a002a.ada | 54 ++ gcc/testsuite/ada/acats/tests/d/d4a002b.ada | 56 ++ gcc/testsuite/ada/acats/tests/d/d4a004a.ada | 59 ++ gcc/testsuite/ada/acats/tests/d/d4a004b.ada | 72 ++ gcc/testsuite/ada/acats/tests/e/e28002b.ada | 111 +++ gcc/testsuite/ada/acats/tests/e/e28005d.ada | 55 ++ gcc/testsuite/ada/acats/tests/e/e52103y.ada | 132 +++ gcc/testsuite/ada/acats/tests/e/eb4011a.ada | 79 ++ gcc/testsuite/ada/acats/tests/e/eb4012a.ada | 59 ++ gcc/testsuite/ada/acats/tests/e/eb4014a.ada | 87 ++ gcc/testsuite/ada/acats/tests/e/ee3203a.ada | 168 ++++ gcc/testsuite/ada/acats/tests/e/ee3204a.ada | 128 +++ gcc/testsuite/ada/acats/tests/e/ee3402b.ada | 118 +++ gcc/testsuite/ada/acats/tests/e/ee3409f.ada | 103 ++ gcc/testsuite/ada/acats/tests/e/ee3412c.ada | 144 +++ gcc/testsuite/ada/acats/tests/gcc/template.ada | 16 + gcc/testsuite/ada/acats/tests/l/la140010.a | 51 + gcc/testsuite/ada/acats/tests/l/la140011.am | 104 ++ gcc/testsuite/ada/acats/tests/l/la140012.a | 55 ++ gcc/testsuite/ada/acats/tests/l/la140020.a | 60 ++ gcc/testsuite/ada/acats/tests/l/la140021.am | 98 ++ gcc/testsuite/ada/acats/tests/l/la140022.a | 66 ++ gcc/testsuite/ada/acats/tests/l/la140030.a | 57 ++ gcc/testsuite/ada/acats/tests/l/la140031.a | 66 ++ gcc/testsuite/ada/acats/tests/l/la140032.am | 101 ++ gcc/testsuite/ada/acats/tests/l/la140033.a | 56 ++ gcc/testsuite/ada/acats/tests/l/la140040.a | 52 + gcc/testsuite/ada/acats/tests/l/la140041.am | 108 +++ gcc/testsuite/ada/acats/tests/l/la140042.a | 53 ++ gcc/testsuite/ada/acats/tests/l/la140050.a | 60 ++ gcc/testsuite/ada/acats/tests/l/la140051.a | 56 ++ gcc/testsuite/ada/acats/tests/l/la140052.am | 110 +++ gcc/testsuite/ada/acats/tests/l/la140053.a | 60 ++ gcc/testsuite/ada/acats/tests/l/la140060.a | 54 ++ gcc/testsuite/ada/acats/tests/l/la140061.a | 66 ++ gcc/testsuite/ada/acats/tests/l/la140062.am | 135 +++ gcc/testsuite/ada/acats/tests/l/la140063.a | 70 ++ gcc/testsuite/ada/acats/tests/l/la140070.a | 62 ++ gcc/testsuite/ada/acats/tests/l/la140071.a | 72 ++ gcc/testsuite/ada/acats/tests/l/la140072.am | 102 ++ gcc/testsuite/ada/acats/tests/l/la140073.a | 63 ++ gcc/testsuite/ada/acats/tests/l/la140080.a | 52 + gcc/testsuite/ada/acats/tests/l/la140081.a | 63 ++ gcc/testsuite/ada/acats/tests/l/la140082.am | 106 +++ gcc/testsuite/ada/acats/tests/l/la140083.a | 61 ++ gcc/testsuite/ada/acats/tests/l/la140090.a | 60 ++ gcc/testsuite/ada/acats/tests/l/la140091.a | 60 ++ gcc/testsuite/ada/acats/tests/l/la140092.am | 110 +++ gcc/testsuite/ada/acats/tests/l/la140093.a | 59 ++ gcc/testsuite/ada/acats/tests/l/la140100.a | 56 ++ gcc/testsuite/ada/acats/tests/l/la140101.a | 89 ++ gcc/testsuite/ada/acats/tests/l/la140102.am | 104 ++ gcc/testsuite/ada/acats/tests/l/la140103.a | 58 ++ gcc/testsuite/ada/acats/tests/l/la140110.a | 64 ++ gcc/testsuite/ada/acats/tests/l/la140111.a | 62 ++ gcc/testsuite/ada/acats/tests/l/la140112.am | 103 ++ gcc/testsuite/ada/acats/tests/l/la140113.a | 59 ++ gcc/testsuite/ada/acats/tests/l/la140120.a | 63 ++ gcc/testsuite/ada/acats/tests/l/la140121.a | 64 ++ gcc/testsuite/ada/acats/tests/l/la140122.am | 102 ++ gcc/testsuite/ada/acats/tests/l/la140123.a | 59 ++ gcc/testsuite/ada/acats/tests/l/la140130.a | 57 ++ gcc/testsuite/ada/acats/tests/l/la140131.a | 58 ++ gcc/testsuite/ada/acats/tests/l/la140132.am | 102 ++ gcc/testsuite/ada/acats/tests/l/la140133.a | 58 ++ gcc/testsuite/ada/acats/tests/l/la140140.a | 55 ++ gcc/testsuite/ada/acats/tests/l/la140141.a | 57 ++ gcc/testsuite/ada/acats/tests/l/la140142.am | 102 ++ gcc/testsuite/ada/acats/tests/l/la140143.a | 64 ++ gcc/testsuite/ada/acats/tests/l/la140150.a | 56 ++ gcc/testsuite/ada/acats/tests/l/la140151.a | 65 ++ gcc/testsuite/ada/acats/tests/l/la140152.am | 101 ++ gcc/testsuite/ada/acats/tests/l/la140153.a | 61 ++ gcc/testsuite/ada/acats/tests/l/la140160.a | 54 ++ gcc/testsuite/ada/acats/tests/l/la140161.a | 63 ++ gcc/testsuite/ada/acats/tests/l/la140162.am | 196 ++++ gcc/testsuite/ada/acats/tests/l/la140163.a | 67 ++ gcc/testsuite/ada/acats/tests/l/la140170.a | 64 ++ gcc/testsuite/ada/acats/tests/l/la140171.a | 69 ++ gcc/testsuite/ada/acats/tests/l/la140172.am | 121 +++ gcc/testsuite/ada/acats/tests/l/la140173.a | 75 ++ gcc/testsuite/ada/acats/tests/l/la140180.a | 65 ++ gcc/testsuite/ada/acats/tests/l/la140181.a | 54 ++ gcc/testsuite/ada/acats/tests/l/la140182.am | 118 +++ gcc/testsuite/ada/acats/tests/l/la140183.a | 60 ++ gcc/testsuite/ada/acats/tests/l/la140190.a | 61 ++ gcc/testsuite/ada/acats/tests/l/la140191.a | 74 ++ gcc/testsuite/ada/acats/tests/l/la140192.am | 107 +++ gcc/testsuite/ada/acats/tests/l/la140193.a | 64 ++ gcc/testsuite/ada/acats/tests/l/la140200.a | 76 ++ gcc/testsuite/ada/acats/tests/l/la140201.a | 71 ++ gcc/testsuite/ada/acats/tests/l/la140202.am | 144 +++ gcc/testsuite/ada/acats/tests/l/la140203.a | 71 ++ gcc/testsuite/ada/acats/tests/l/la140210.a | 69 ++ gcc/testsuite/ada/acats/tests/l/la140211.am | 134 +++ gcc/testsuite/ada/acats/tests/l/la140212.a | 74 ++ gcc/testsuite/ada/acats/tests/l/la140220.a | 64 ++ gcc/testsuite/ada/acats/tests/l/la140221.am | 128 +++ gcc/testsuite/ada/acats/tests/l/la140222.a | 69 ++ gcc/testsuite/ada/acats/tests/l/la140240.a | 61 ++ gcc/testsuite/ada/acats/tests/l/la140241.a | 55 ++ gcc/testsuite/ada/acats/tests/l/la140242.am | 104 ++ gcc/testsuite/ada/acats/tests/l/la140243.a | 61 ++ gcc/testsuite/ada/acats/tests/l/la140250.a | 56 ++ gcc/testsuite/ada/acats/tests/l/la140251.am | 141 +++ gcc/testsuite/ada/acats/tests/l/la140252.a | 59 ++ gcc/testsuite/ada/acats/tests/l/la140260.a | 98 ++ gcc/testsuite/ada/acats/tests/l/la140261.a | 52 + gcc/testsuite/ada/acats/tests/l/la140262.am | 140 +++ gcc/testsuite/ada/acats/tests/l/la140263.a | 57 ++ gcc/testsuite/ada/acats/tests/l/la140270.a | 56 ++ gcc/testsuite/ada/acats/tests/l/la140271.a | 93 ++ gcc/testsuite/ada/acats/tests/l/la140272.am | 102 ++ gcc/testsuite/ada/acats/tests/l/la140273.a | 58 ++ 2524 files changed, 424720 insertions(+) create mode 100644 gcc/testsuite/ada/acats/tests/a/a22006b.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a22006c.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a22006d.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a26007a.tst create mode 100644 gcc/testsuite/ada/acats/tests/a/a27003a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a29003a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a2a031a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a33003a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a34017c.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a35101b.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a35402a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a35801f.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a35902c.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a38106d.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a38106e.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a49027a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a49027b.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a49027c.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a54b01a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a54b02a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a55b12a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a55b13a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a55b14a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a71004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a73001i.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a73001j.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a74105b.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a74106a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a74106b.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a74106c.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a74205e.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a74205f.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a83009a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a83009b.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a83a02a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a83a02b.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a83a06a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a83a08a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a83c01c.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a83c01h.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a83c01i.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a85007d.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a85013b.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a87b59a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a95001c.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a95074d.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a97106a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/a99006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/aa2010a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/aa2012a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ac1015b.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ac3106a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ac3206a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ac3207a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ad7001b.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ad7001c0.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ad7001c1.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ad7001d0.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ad7001d1.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ad7006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ad7101a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ad7101c.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ad7102a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ad7103a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ad7103c.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ad7104a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ad7201a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ad7203b.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ad7205b.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ad8011a.tst create mode 100644 gcc/testsuite/ada/acats/tests/a/ada101a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ae2113a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ae2113b.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ae3002g.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ae3101a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ae3702a.ada create mode 100644 gcc/testsuite/ada/acats/tests/a/ae3709a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c23001a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c23003a.tst create mode 100644 gcc/testsuite/ada/acats/tests/c2/c23003b.tst create mode 100644 gcc/testsuite/ada/acats/tests/c2/c23003g.tst create mode 100644 gcc/testsuite/ada/acats/tests/c2/c23003i.tst create mode 100644 gcc/testsuite/ada/acats/tests/c2/c23006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c23006b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c23006c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c23006d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c23006e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c23006f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c23006g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c24002d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c24003a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c24003b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c24003c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c24106a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c24202d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c24203a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c24203b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c24207a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c24211a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c250001.aw create mode 100644 gcc/testsuite/ada/acats/tests/c2/c250002.aw create mode 100644 gcc/testsuite/ada/acats/tests/c2/c25001a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c25001b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c26006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c26008a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c2a001a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c2a001b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c2a001c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c2a002a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c2a008a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c2/c2a021b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c32001a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c32001b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c32001c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c32001d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c32001e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c32107a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c32107c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c32108a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c32108b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c32111a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c32111b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c32112b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c32113a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c32115a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c32115b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c330001.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c330002.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c332001.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c340001.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34001a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34001c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34001d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34001f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34002a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34002c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34003a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34003c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34004c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34005a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34005c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34005d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34005f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34005g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34005i.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34005j.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34005l.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34005m.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34005o.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34005p.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34005r.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34005s.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34005u.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34005v.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34006d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34006f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34006g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34006j.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34006l.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34007a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34007d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34007f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34007g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34007i.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34007j.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34007m.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34007p.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34007r.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34007s.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34007u.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34007v.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34008a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34009a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34009d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34009f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34009g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34009j.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34009l.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34011b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34012a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34014a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34014c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34014e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34014g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34014h.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34014n.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34014p.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34014r.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34014t.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34014u.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c34018a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c340a01.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c340a02.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c341a01.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c341a02.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c341a03.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c341a04.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35003a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35003b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35003d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35102a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c354002.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c354003.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35502a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35502b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35502c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35502d.tst create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35502e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35502f.tst create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35502g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35502h.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35502i.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35502j.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35502k.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35502l.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35502m.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35502n.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35502o.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35502p.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35503a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35503b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35503c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35503d.tst create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35503e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35503f.tst create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35503g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35503h.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35503k.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35503l.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35503o.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35503p.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35504a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35504b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35505c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35505e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35505f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35507a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35507b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35507c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35507e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35507g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35507h.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35507i.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35507j.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35507k.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35507l.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35507m.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35507n.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35507o.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35507p.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35508a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35508b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35508c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35508e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35508g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35508h.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35508k.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35508l.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35508o.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35508p.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35703a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35704a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35704b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35704c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35704d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35801d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35902d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35904a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35904b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35a02a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35a05a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35a05d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35a05n.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35a05q.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35a07a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35a07d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c35a08b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c360002.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36104a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36104b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36172a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36172b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36172c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36174a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36180a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36202c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36203a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36204a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36204b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36204c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36204d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36205a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36205b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36205c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36205d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36205e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36205f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36205g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36205h.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36205i.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36205j.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36205k.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36205l.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36301a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36301b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36302a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36304a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c36305a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37002a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37003a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37003b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37005a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37008a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37008b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37009a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37010a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37010b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c371001.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c371002.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c371003.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37102b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37103a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37105a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37107a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37108b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37206a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37207a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37208a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37208b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37209a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37209b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37210a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37211a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37211b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37211c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37211d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37211e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37213b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37213d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37213f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37213h.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37213j.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37213k.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37213l.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37215b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37215d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37215f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37215h.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37217a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37217b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37217c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37304a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37305a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37306a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37309a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37310a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37312a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37402a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37403a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37404a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37404b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37405a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c37411a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c380001.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c380002.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c380003.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c380004.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c38002a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c38002b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c38005a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c38005b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c38005c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c38006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c38102a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c38102b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c38102c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c38102d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c38102e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c38104a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c38107a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c38107b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c38108a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c38108b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c38108c0.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c38108c1.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c38108c2.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c38108d0.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c38108d1.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c38202a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3900010.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3900011.am create mode 100644 gcc/testsuite/ada/acats/tests/c3/c390002.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c390003.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c390004.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3900050.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3900051.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3900052.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3900053.am create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3900060.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3900061.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3900062.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3900063.am create mode 100644 gcc/testsuite/ada/acats/tests/c3/c390007.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c390010.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c390011.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c39006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c39006b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c39006c0.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c39006c1.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c39006d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c39006e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c39006f0.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c39006f1.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c39006f2.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c39006f3.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c39006g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c39007a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c39007b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c39008a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c39008b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c39008c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c3/c390a010.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c390a011.am create mode 100644 gcc/testsuite/ada/acats/tests/c3/c390a020.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c390a021.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c390a022.am create mode 100644 gcc/testsuite/ada/acats/tests/c3/c390a030.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c390a031.am create mode 100644 gcc/testsuite/ada/acats/tests/c3/c391001.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c391002.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c392002.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c392003.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c392004.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c392005.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c392008.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c392010.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c392011.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c392013.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c392014.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c392a01.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c392c05.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c392c07.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c392d01.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c392d02.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c392d03.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c393001.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c393007.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c393008.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c393009.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c393010.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c393011.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c393012.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c393a02.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c393a03.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c393a05.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c393a06.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c393b12.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c393b13.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c393b14.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a0001.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a0002.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a0003.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a0004.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a0005.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a0006.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a0007.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a0008.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a0009.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a0010.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a0011.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a00120.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a00121.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a00122.am create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a0013.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a0014.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a0015.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a1001.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a1002.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a2001.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a2002.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a2003.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a2a01.a create mode 100644 gcc/testsuite/ada/acats/tests/c3/c3a2a02.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c410001.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41101d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41103a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41103b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41104a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41105a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41107a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41201d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41203a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41203b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41204a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41205a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41206a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41207a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41301a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41303a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41303b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41303c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41303e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41303f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41303g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41303i.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41303j.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41303k.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41303m.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41303n.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41303o.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41303q.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41303r.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41303s.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41303u.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41303v.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41303w.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41304a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41304b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41306a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41306b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41306c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41307d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41309a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41320a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41321a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41322a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41323a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41324a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41325a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41326a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41327a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41328a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41401a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41402a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c41404a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c420001.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c42006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c42007e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43003a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43004c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c431001.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43103a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43103b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43104a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43105a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43105b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43106a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43107a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43108a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c432001.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c432002.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c432003.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c432004.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43204a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43204c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43204e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43204f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43204g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43204h.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43204i.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43205a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43205b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43205c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43205d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43205e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43205g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43205h.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43205i.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43205j.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43205k.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43206a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43207b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43207d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43208a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43208b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43209a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43210a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43211a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43212a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43212c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43214a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43214b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43214c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43214d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43214e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43214f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43215a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43215b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43222a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c43224a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c433001.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c44003d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c44003f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c44003g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c450001.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45112a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45112b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45113a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45114b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c452001.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45201a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45201b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45202b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45210a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45211a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45220a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45220b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45220c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45220d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45220e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45220f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45231a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45231b.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45231c.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45231d.tst create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45232b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45242b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45251a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45252a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45252b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45253a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45262a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45262b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45262c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45262d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45264a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45264b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45264c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45265a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45271a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45272a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45273a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45274a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45274b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45274c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45281a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45282a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45282b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45291a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45303a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45304a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45304b.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45304c.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45322a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45323a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45331a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45342a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45343a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45344a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45345b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45347a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45347b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45347c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45347d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45411a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45411b.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45411c.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45411d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45413a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45431a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c455001.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45502b.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45502c.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45503a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45503b.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45503c.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45504a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45504b.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45504c.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45504d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45504e.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45504f.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45505a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45523a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45531a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45531b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45531c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45531d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45531e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45531f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45531g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45531h.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45531i.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45531j.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45531k.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45531l.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45531m.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45531n.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45531o.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45531p.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45532a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45532b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45532c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45532d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45532e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45532f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45532g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45532h.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45532i.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45532j.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45532k.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45532l.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45532m.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45532n.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45532o.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45532p.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45534b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45536a.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c456001.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45611a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45611b.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45611c.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45613a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45613b.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45613c.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45614a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45614b.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45614c.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45622a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45624a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45624b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45631a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45631b.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45631c.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45632a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45632b.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45632c.dep create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45651a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45662a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45662b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c45672a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c460001.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c460002.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c460004.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c460005.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c460006.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c460007.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c460008.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c460009.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c460010.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c460011.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c460012.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c46011a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c46013a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c46014a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c46021a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c46024a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c46031a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c46032a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c46033a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c46041a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c46042a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c46043b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c46044b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c46051a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c46051b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c46051c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c46052a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c46053a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c46054a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c460a01.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c460a02.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c47002a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c47002b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c47002c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c47002d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c47003a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c47004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c47005a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c47006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c47007a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c47008a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c47009a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c47009b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48004b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48004c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48004d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48004e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48004f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48005a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48005b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48006b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48007a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48007b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48007c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48008a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48008c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48009a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48009b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48009c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48009d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48009e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48009f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48009g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48009h.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48009i.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48009j.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48010a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48011a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c48012a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c490001.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c490002.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c490003.a create mode 100644 gcc/testsuite/ada/acats/tests/c4/c49020a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c49021a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c49022a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c49022b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c49022c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c49023a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c49024a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c49025a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c49026a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c4a005b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c4a006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c4a007a.tst create mode 100644 gcc/testsuite/ada/acats/tests/c4/c4a010a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c4a010b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c4a011a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c4a012b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c4a013a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c4/c4a014a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c51004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52005a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52005b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52005c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52005d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52005e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52005f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52008a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52008b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52009a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52009b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52010a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52011a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52011b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52101a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52102a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52102b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52102c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52102d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52103a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52103b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52103c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52103f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52103g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52103h.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52103k.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52103l.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52103m.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52103p.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52103q.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52103r.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52103x.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52104a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52104b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52104c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52104f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52104g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52104h.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52104k.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52104l.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52104m.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52104p.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52104q.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52104r.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52104x.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c52104y.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c53007a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c540001.a create mode 100644 gcc/testsuite/ada/acats/tests/c5/c54a03a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c54a04a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c54a07a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c54a13a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c54a13b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c54a13c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c54a13d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c54a22a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c54a23a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c54a24a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c54a24b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c54a42a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c54a42b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c54a42c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c54a42d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c54a42e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c54a42f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c54a42g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c55b03a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c55b04a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c55b05a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c55b06a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c55b06b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c55b07a.dep create mode 100644 gcc/testsuite/ada/acats/tests/c5/c55b07b.dep create mode 100644 gcc/testsuite/ada/acats/tests/c5/c55b10a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c55b11a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c55b11b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c55b15a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c55b16a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c55c02a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c55c02b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c56002a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c57003a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c57004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c57004b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c58004c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c58004d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c58004g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c58005a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c58005b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c58005h.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c58006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c58006b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c59002a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c59002b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c5/c59002c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c61008a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c61009a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c61010a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c62002a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c62003a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c62003b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c62004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c62006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c631001.a create mode 100644 gcc/testsuite/ada/acats/tests/c6/c640001.a create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64002b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64004g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64005a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64005b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64005c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64005d0.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64005da.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64005db.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64005dc.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c641001.a create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64103b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64103c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64103d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64103e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64103f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64104a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64104b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64104c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64104d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64104e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64104f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64104g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64104h.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64104i.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64104j.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64104k.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64104l.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64104m.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64104n.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64104o.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64105a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64105b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64105c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64105d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64106a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64106b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64106c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64106d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64107a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64108a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64109a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64109b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64109c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64109d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64109e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64109f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64109g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64109h.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64109i.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64109j.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64109k.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64109l.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64201b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64201c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c64202a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c650001.a create mode 100644 gcc/testsuite/ada/acats/tests/c6/c65003a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c65003b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c66002a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c66002c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c66002d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c66002e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c66002f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c66002g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c67002a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c67002b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c67002c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c67002d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c67002e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c67003f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c67005a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c67005b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c67005c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c6/c67005d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c72001b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c72002a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c730001.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c730002.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c730003.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c730004.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c73002a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c730a01.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c730a02.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c731001.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74203a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74206a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74207b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74208a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74208b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74209a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74210a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74211a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74211b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74302a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74302b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74305a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74305b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74306a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74307a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74401d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74401e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74401k.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74401q.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74402a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74402b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74406a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74407b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c74409b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c7/c760001.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c760002.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c760007.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c760009.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c760010.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c760011.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c760012.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c760013.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c761001.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c761002.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c761003.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c761004.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c761005.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c761006.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c761007.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c761010.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c761011.a create mode 100644 gcc/testsuite/ada/acats/tests/c7/c761012.a create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83007a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83012d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83022a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83022g0.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83022g1.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83023a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83024a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83024e0.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83024e1.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83025a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83025c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83027a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83027c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83028a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83029a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83030a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83030c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83031a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83031c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83031e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83032a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83033a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83051a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83b02a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83b02b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83e02a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83e02b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83e03a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83f01a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83f01b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83f01c0.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83f01c1.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83f01c2.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83f01d0.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83f01d1.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83f03a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83f03b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83f03c0.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83f03c1.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83f03c2.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83f03d0.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c83f03d1.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c840001.a create mode 100644 gcc/testsuite/ada/acats/tests/c8/c84002a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c84005a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c84008a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c84009a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85004b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85005a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85005b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85005c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85005d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85005e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85005f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85005g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85006b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85006c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85006d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85006e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85006f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85006g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85007a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85007e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85009a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85011a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85013a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85014a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85014b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85014c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85017a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85018a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85018b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c85019a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c854001.a create mode 100644 gcc/testsuite/ada/acats/tests/c8/c854002.a create mode 100644 gcc/testsuite/ada/acats/tests/c8/c854003.a create mode 100644 gcc/testsuite/ada/acats/tests/c8/c86003a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c86004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c86004b0.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c86004b1.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c86004b2.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c86004c0.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c86004c1.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c86004c2.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c86006i.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c86007a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87a05a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87a05b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b02a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b02b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b03a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b04a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b04b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b04c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b05a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b06a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b07a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b07b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b07c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b07d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b07e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b08a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b09a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b09c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b10a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b11a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b11b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b13a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b14a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b14b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b14c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b14d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b15a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b16a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b17a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b18a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b18b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b19a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b23a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b24a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b24b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b26b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b27a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b28a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b29a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b30a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b31a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b32a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b33a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b34a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b34b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b34c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b35c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b38a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b39a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b40a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b41a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b42a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b43a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b44a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b45a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b45c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b47a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b48a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b48b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b50a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b54a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b57a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b62a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b62b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b62c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c8/c87b62d.tst create mode 100644 gcc/testsuite/ada/acats/tests/c9/c910001.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c910002.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c910003.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c91004b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c91004c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c91006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c91007a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c92002a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c92003a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c92005a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c92005b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c92006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c930001.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c93001a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c93002a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c93003a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c93004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c93004b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c93004c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c93004d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c93004f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c93005a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c93005b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c93005c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c93005d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c93005e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c93005f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c93005g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c93005h.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c93006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c93007a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c93008a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c93008b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c940001.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c940002.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c940004.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c940005.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c940006.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c940007.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c940010.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c940011.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c940012.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c940013.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c940014.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c940015.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c940016.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94001a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94001b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94001c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94001e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94001f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94001g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94002a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94002b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94002d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94002e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94002f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94002g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94004b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94004c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94005a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94005b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94007a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94007b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94008a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94008b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94008c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94008d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94010a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94011a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c94020a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c940a03.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95008a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95009a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95010a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95011a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95012a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95021a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95022a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95022b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95033a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95033b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95034a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95034b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95035a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95040a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95040b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95040c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95040d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95041a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95065a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95065b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95065c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95065d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95065e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95065f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95066a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95067a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95071a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95072a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95072b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95073a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95074c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95076a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95078a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95080b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95082g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95085a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95085b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95085c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95085d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95085e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95085f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95085g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95085h.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95085i.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95085j.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95085k.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95085l.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95085m.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95085n.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95085o.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95086a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95086b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95086c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95086d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95086e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95086f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95087a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95087b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95087c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95087d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95088a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95089a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95090a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95092a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95093a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95095a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95095b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95095c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95095d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c95095e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c951001.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c951002.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c953001.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c953002.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c953003.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c954001.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c954010.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c954011.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c954012.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c954013.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c954014.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c954015.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c954016.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c954017.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c954018.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c954019.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c954020.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c954021.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c954022.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c954023.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c954024.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c954025.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c954026.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c954a01.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c954a02.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c954a03.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c960001.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c960002.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c960004.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c96001a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c96004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c96005a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c96005b.tst create mode 100644 gcc/testsuite/ada/acats/tests/c9/c96005d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c96005f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c96006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c96007a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c96008a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c96008b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97112a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97113a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97114a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97115a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97116a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97117a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97117b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97117c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97118a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97120a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97120b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97201a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97201b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97201c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97201d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97201e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97201g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97201h.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97201x.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97202a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97203a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97203b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97203c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97204a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97204b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97205a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97205b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97301a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97301b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97301c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97301d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97301e.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97302a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97303a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97303b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97303c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97304a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97304b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97305a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97305b.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97305c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97305d.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c97307a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c974001.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c974002.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c974003.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c974004.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c974005.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c974006.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c974007.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c974008.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c974009.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c974010.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c974011.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c974012.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c974013.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c974014.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c980001.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c980002.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c980003.a create mode 100644 gcc/testsuite/ada/acats/tests/c9/c99004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c99005a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c9a003a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c9a004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c9a007a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c9a009a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c9a009c.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c9a009f.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c9a009g.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c9a009h.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c9a010a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c9a011a.ada create mode 100644 gcc/testsuite/ada/acats/tests/c9/c9a011b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1003a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1005a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1011a0.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1011a1.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1011a2.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1011a3.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1011a4.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1011a5.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1011a6.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1012a0.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1012a1.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1012a2.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1012a3.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1012a4.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1012b0.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1012b2.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1012b4.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1013a0.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1013a1.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1013a2.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1013a3.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1013a4.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1013a5.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1013a6.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1014a0.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1014a1.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1014a2.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1014a3.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1020e0.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1020e1.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1020e2.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1020e3.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1022a0.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1022a1.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1022a2.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1022a3.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1022a4.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1022a5.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1022a6.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11001.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11002.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11003.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca110040.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca110041.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca110042.am create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca110050.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca110051.am create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11006.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11007.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11008.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11009.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11010.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11011.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11012.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11013.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11014.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11015.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11016.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11017.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11018.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11019.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11020.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11021.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11022.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1102a0.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1102a1.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1102a2.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1106a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1108a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca1108b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11a01.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11a02.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11b01.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11b02.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11c01.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11c02.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11c03.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11d010.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11d011.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11d012.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11d013.am create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11d02.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca11d03.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca13001.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca13002.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca13003.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca13a01.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca13a02.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca140230.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca140231.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca140232.am create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca140233.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca140280.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca140281.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca140282.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca140283.am create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca15003.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca200020.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca200021.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca200022.am create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2001h0.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2001h1.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2001h2.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2001h3.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2002a0.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2002a1.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2002a2.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2003a0.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2003a1.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2004a0.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2004a1.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2004a2.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2004a3.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2004a4.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2007a0.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2007a1.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2007a2.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2007a3.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2008a0.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2008a1.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2008a2.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2009a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2009c0.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2009c1.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2009d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2009f0.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2009f1.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2009f2.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca2011b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca21001.a create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca3011a0.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca3011a1.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca3011a2.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca3011a3.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca3011a4.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca5003a0.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca5003a1.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca5003a2.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca5003a3.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca5003a4.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca5003a5.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca5003a6.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca5003b0.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca5003b1.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca5003b2.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca5003b3.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca5003b4.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca5003b5.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca5004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca5004b0.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca5004b1.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca5004b2.ada create mode 100644 gcc/testsuite/ada/acats/tests/ca/ca5006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb10002.a create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb1001a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb1004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb1005a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb1010a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb1010c.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb1010d.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb20001.a create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb20003.a create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb20004.a create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb20005.a create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb20006.a create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb20007.a create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb2004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb2005a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb2006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb2007a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb20a02.a create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb3003a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb3003b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb3004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb40005.a create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb4001a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb4002a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb4003a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb4004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb4005a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb4006a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb4007a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb4008a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb4009a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb4013a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb40a01.a create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb40a020.a create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb40a021.am create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb40a030.a create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb40a031.am create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb40a04.a create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb41001.a create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb41002.a create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb41003.a create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb41004.a create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb5001a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb5001b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cb/cb5002a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1005b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1010a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1010b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1018a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1104c.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1107b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1111a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1204a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1207b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1220a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1221a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1221b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1221c.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1221d.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1222a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1223a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1224a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1225a.tst create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1226b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1227a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1301a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1302a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1304a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1304b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1307a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1307b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1308a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1310a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1311a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc1311b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc2002a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc30001.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc30002.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3007a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3007b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3011a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3011d.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3012a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3015a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3016b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3016c.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3016f.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3016i.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3017b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3017c.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3019a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3019b0.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3019b1.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3019b2.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3019c0.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3019c1.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3019c2.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3106b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3120a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3120b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3121a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3123a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3125a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3125b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3125c.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3125d.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3126a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3127a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3128a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3203a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3207b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3220a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3221a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3222a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3223a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3224a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3225a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3230a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3231a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3232a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3233a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3234a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3235a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3236a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3240a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3305a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3305b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3305c.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3305d.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3601a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3601c.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3602a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3603a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3605a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3606a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3606b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc3607b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc40001.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc50001.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc50a01.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc50a02.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc51001.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc51002.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc51003.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc51004.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc51006.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc51007.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc51008.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc51a01.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc51b03.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc51d01.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc51d02.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc54001.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc54002.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc54003.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc54004.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc70001.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc70002.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc70003.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc70a01.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc70a02.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc70b01.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc70b02.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc70c01.a create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc70c02.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd10001.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd10002.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009d.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009e.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009f.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009g.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009h.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009i.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009j.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009k.tst create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009l.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009m.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009n.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009o.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009p.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009q.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009r.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009s.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009t.tst create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009u.tst create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009v.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009w.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009x.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009y.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1009z.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1c03a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1c03b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1c03c.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1c03e.tst create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1c03f.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1c03g.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1c03h.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1c03i.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1c04a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1c04d.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1c04e.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd1c06a.tst create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd20001.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a21a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a21c.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a21e.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a22a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a22e.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a22i.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a22j.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a23a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a23e.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a24a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a24e.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a24i.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a24j.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a31a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a31c.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a31e.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a32a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a32c.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a32e.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a32g.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a32i.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a32j.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a51a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a53a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a53e.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a83c.tst create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2a91c.tst create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2b11a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2b11b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2b11d.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2b11e.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2b11f.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2b15c.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2b16a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2c11a.tst create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2c11d.tst create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2d11a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd2d13a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd30001.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd30002.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd30003.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd30004.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd300050.am create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd300051.c create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd3014a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd3014c.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd3014d.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd3014f.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd3015a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd3015c.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd3015e.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd3015f.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd3015g.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd3015h.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd3015i.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd3015k.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd3021a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd33001.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd33002.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd40001.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd4031a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd4041a.tst create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd4051a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd4051b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd4051c.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd4051d.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5003a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5003b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5003c.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5003d.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5003e.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5003f.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5003g.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5003h.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5003i.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5011a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5011c.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5011e.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5011g.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5011i.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5011k.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5011m.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5011q.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5011s.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5012a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5012b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5012e.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5012f.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5012i.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5012m.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5013a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5013c.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5013e.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5013g.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5013i.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5013k.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5013m.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5013o.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5014a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5014c.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5014e.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5014g.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5014i.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5014k.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5014m.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5014o.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5014t.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5014v.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5014x.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5014y.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd5014z.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd70001.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd7002a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd7007b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd7101d.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd7101e.dep create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd7101f.dep create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd7101g.tst create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd7103d.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd7202a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd7204b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd7204c.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd72a01.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd72a02.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd7305a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd90001.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cd92001.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cda201a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cda201b.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cda201c.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cda201e.ada create mode 100644 gcc/testsuite/ada/acats/tests/cd/cdb0a01.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cdb0a02.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cdd1001.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cdd2001.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cdd2a01.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cdd2a02.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cdd2a03.a create mode 100644 gcc/testsuite/ada/acats/tests/cd/cde0001.a create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102c.tst create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102e.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102f.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102g.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102h.tst create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102i.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102j.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102k.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102l.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102m.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102n.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102o.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102p.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102q.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102r.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102s.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102t.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102u.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102v.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102w.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102x.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2102y.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2103a.tst create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2103b.tst create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2103c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2103d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2104a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2104b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2104c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2104d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2106a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2106b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2108e.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2108f.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2108g.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2108h.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2109a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2109b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2109c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2110a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2110c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2111a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2111b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2111c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2111e.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2111f.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2111g.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2111i.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2201a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2201b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2201c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2201d.dep create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2201e.dep create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2201f.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2201g.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2201h.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2201i.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2201j.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2201k.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2201l.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2201m.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2201n.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2202a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2203a.tst create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2204a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2204b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2204c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2204d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2205a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2206a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2208b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2401a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2401b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2401c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2401e.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2401f.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2401h.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2401i.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2401j.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2401k.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2401l.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2402a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2403a.tst create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2404a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2404b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2405b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2406a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2407a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2407b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2408a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2408b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2409a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2409b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2410a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2410b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce2411a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3002b.tst create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3002c.tst create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3002d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3002f.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3102a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3102b.tst create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3102d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3102e.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3102f.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3102g.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3102h.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3102i.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3102j.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3102k.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3103a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3104a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3104b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3104c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3106a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3106b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3107a.tst create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3107b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3108a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3108b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3110a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3112c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3112d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3114a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3115a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3201a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3202a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3206a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3207a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3301a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3302a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3303a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3304a.tst create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3305a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3306a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3401a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3402a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3402c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3402d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3402e.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3403a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3403b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3403c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3403d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3403e.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3403f.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3404a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3404b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3404c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3404d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3405a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3405c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3405d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3406a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3406b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3406c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3406d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3407a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3407b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3407c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3408a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3408b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3408c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3409a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3409b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3409c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3409d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3409e.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3410a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3410b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3410c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3410d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3410e.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3411a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3411c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3412a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3413a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3413b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3413c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3414a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3601a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3602a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3602b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3602c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3602d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3603a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3604a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3604b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3605a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3605b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3605c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3605d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3605e.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3606a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3606b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3701a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3704a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3704b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3704c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3704d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3704e.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3704f.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3704m.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3704n.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3704o.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3705a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3705b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3705c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3705d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3705e.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3706c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3706d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3706f.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3706g.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3707a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3708a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3801a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3801b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3804a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3804b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3804c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3804d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3804e.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3804f.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3804g.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3804h.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3804i.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3804j.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3804m.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3804o.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3804p.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3805a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3805b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3806a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3806b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3806c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3806d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3806e.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3806f.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3806g.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3806h.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3809a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3809b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3810a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3810b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3815a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3901a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3902b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3904a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3904b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3905a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3905b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3905c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3905l.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3906a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3906b.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3906c.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3906d.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3906e.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3906f.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3907a.ada create mode 100644 gcc/testsuite/ada/acats/tests/ce/ce3908a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa3001.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa3002.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa3003.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4001.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4002.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4003.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4004.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4005.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4006.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4007.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4008.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4009.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4010.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4011.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4012.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4013.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4014.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4015.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4016.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4017.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4018.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4019.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4020.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4021.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4022.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4023.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4024.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4025.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4026.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4027.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4028.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4029.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4030.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4031.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4032.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4033.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa4034.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa5011.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa5012.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa5015.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa5a01.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa5a02.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa5a03.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa5a04.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa5a05.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa5a06.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa5a07.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa5a08.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa5a09.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa5a10.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa8001.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa8002.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa8003.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa9001.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxa9002.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxaa001.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxaa002.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxaa003.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxaa004.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxaa005.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxaa006.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxaa007.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxaa008.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxaa009.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxaa010.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxaa011.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxaa012.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxaa013.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxaa014.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxaa015.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxaa016.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxaa017.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxaa018.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxaa019.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxab001.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxac001.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxac002.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxac003.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxac004.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxac005.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxaca01.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxaca02.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxacb01.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxacb02.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxacc01.a create mode 100644 gcc/testsuite/ada/acats/tests/cxa/cxaf001.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb2001.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb2002.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb2003.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb3001.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb3002.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb3003.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb30040.c create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb30041.am create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb3005.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb30060.c create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb3007.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb3008.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb3009.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb3010.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb3011.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb3012.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb30130.c create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb30131.c create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb30132.am create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb3014.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb3015.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb3016.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb4001.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb4002.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb4003.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb4004.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb4005.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb4006.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb4007.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb4008.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb5001.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb5002.a create mode 100644 gcc/testsuite/ada/acats/tests/cxb/cxb5003.a create mode 100644 gcc/testsuite/ada/acats/tests/cxf/cxf1001.a create mode 100644 gcc/testsuite/ada/acats/tests/cxf/cxf2001.a create mode 100644 gcc/testsuite/ada/acats/tests/cxf/cxf2002.a create mode 100644 gcc/testsuite/ada/acats/tests/cxf/cxf2003.a create mode 100644 gcc/testsuite/ada/acats/tests/cxf/cxf2004.a create mode 100644 gcc/testsuite/ada/acats/tests/cxf/cxf2005.a create mode 100644 gcc/testsuite/ada/acats/tests/cxf/cxf2a01.a create mode 100644 gcc/testsuite/ada/acats/tests/cxf/cxf2a02.a create mode 100644 gcc/testsuite/ada/acats/tests/cxf/cxf3001.a create mode 100644 gcc/testsuite/ada/acats/tests/cxf/cxf3002.a create mode 100644 gcc/testsuite/ada/acats/tests/cxf/cxf3003.a create mode 100644 gcc/testsuite/ada/acats/tests/cxf/cxf3004.a create mode 100644 gcc/testsuite/ada/acats/tests/cxf/cxf3a01.a create mode 100644 gcc/testsuite/ada/acats/tests/cxf/cxf3a02.a create mode 100644 gcc/testsuite/ada/acats/tests/cxf/cxf3a03.a create mode 100644 gcc/testsuite/ada/acats/tests/cxf/cxf3a04.a create mode 100644 gcc/testsuite/ada/acats/tests/cxf/cxf3a05.a create mode 100644 gcc/testsuite/ada/acats/tests/cxf/cxf3a06.a create mode 100644 gcc/testsuite/ada/acats/tests/cxf/cxf3a07.a create mode 100644 gcc/testsuite/ada/acats/tests/cxf/cxf3a08.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg1001.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg1002.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg1003.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg1004.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg1005.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2001.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2002.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2003.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2004.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2005.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2006.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2007.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2008.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2009.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2010.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2011.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2012.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2013.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2014.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2015.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2016.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2017.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2018.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2019.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2020.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2021.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2022.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2023.a create mode 100644 gcc/testsuite/ada/acats/tests/cxg/cxg2024.a create mode 100644 gcc/testsuite/ada/acats/tests/cxh/cxh1001.a create mode 100644 gcc/testsuite/ada/acats/tests/cxh/cxh3001.a create mode 100644 gcc/testsuite/ada/acats/tests/cxh/cxh3002.a create mode 100644 gcc/testsuite/ada/acats/tests/cxh/cxh30030.a create mode 100644 gcc/testsuite/ada/acats/tests/cxh/cxh30031.am create mode 100644 gcc/testsuite/ada/acats/tests/cz/cz1101a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cz/cz1102a.ada create mode 100644 gcc/testsuite/ada/acats/tests/cz/cz1103a.ada create mode 100644 gcc/testsuite/ada/acats/tests/d/d4a002a.ada create mode 100644 gcc/testsuite/ada/acats/tests/d/d4a002b.ada create mode 100644 gcc/testsuite/ada/acats/tests/d/d4a004a.ada create mode 100644 gcc/testsuite/ada/acats/tests/d/d4a004b.ada create mode 100644 gcc/testsuite/ada/acats/tests/e/e28002b.ada create mode 100644 gcc/testsuite/ada/acats/tests/e/e28005d.ada create mode 100644 gcc/testsuite/ada/acats/tests/e/e52103y.ada create mode 100644 gcc/testsuite/ada/acats/tests/e/eb4011a.ada create mode 100644 gcc/testsuite/ada/acats/tests/e/eb4012a.ada create mode 100644 gcc/testsuite/ada/acats/tests/e/eb4014a.ada create mode 100644 gcc/testsuite/ada/acats/tests/e/ee3203a.ada create mode 100644 gcc/testsuite/ada/acats/tests/e/ee3204a.ada create mode 100644 gcc/testsuite/ada/acats/tests/e/ee3402b.ada create mode 100644 gcc/testsuite/ada/acats/tests/e/ee3409f.ada create mode 100644 gcc/testsuite/ada/acats/tests/e/ee3412c.ada create mode 100644 gcc/testsuite/ada/acats/tests/gcc/template.ada create mode 100644 gcc/testsuite/ada/acats/tests/l/la140010.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140011.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140012.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140020.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140021.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140022.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140030.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140031.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140032.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140033.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140040.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140041.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140042.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140050.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140051.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140052.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140053.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140060.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140061.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140062.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140063.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140070.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140071.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140072.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140073.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140080.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140081.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140082.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140083.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140090.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140091.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140092.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140093.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140100.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140101.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140102.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140103.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140110.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140111.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140112.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140113.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140120.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140121.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140122.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140123.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140130.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140131.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140132.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140133.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140140.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140141.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140142.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140143.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140150.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140151.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140152.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140153.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140160.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140161.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140162.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140163.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140170.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140171.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140172.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140173.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140180.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140181.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140182.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140183.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140190.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140191.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140192.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140193.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140200.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140201.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140202.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140203.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140210.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140211.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140212.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140220.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140221.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140222.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140240.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140241.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140242.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140243.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140250.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140251.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140252.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140260.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140261.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140262.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140263.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140270.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140271.a create mode 100644 gcc/testsuite/ada/acats/tests/l/la140272.am create mode 100644 gcc/testsuite/ada/acats/tests/l/la140273.a (limited to 'gcc/testsuite/ada/acats/tests') diff --git a/gcc/testsuite/ada/acats/tests/a/a22006b.ada b/gcc/testsuite/ada/acats/tests/a/a22006b.ada new file mode 100644 index 000000000..250caf2d6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a22006b.ada @@ -0,0 +1,38 @@ +-- 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 new file mode 100644 index 000000000..e04eb1223 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a22006c.ada @@ -0,0 +1,51 @@ + + + +-- 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 new file mode 100644 index 000000000..d19362c9d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a22006d.ada @@ -0,0 +1,41 @@ + -- 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 new file mode 100644 index 000000000..d40aa3d13 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a26007a.tst @@ -0,0 +1,48 @@ +-- 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 new file mode 100644 index 000000000..77234e57d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a27003a.ada @@ -0,0 +1,51 @@ +-- 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 new file mode 100644 index 000000000..e72de7959 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a29003a.ada @@ -0,0 +1,102 @@ +-- 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 new file mode 100644 index 000000000..f89f904e6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a2a031a.ada @@ -0,0 +1,72 @@ +-- 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 new file mode 100644 index 000000000..8fe513fbf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a33003a.ada @@ -0,0 +1,49 @@ +-- 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 new file mode 100644 index 000000000..8884f46f6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a34017c.ada @@ -0,0 +1,105 @@ +-- 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 new file mode 100644 index 000000000..a8e5d122b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a35101b.ada @@ -0,0 +1,50 @@ +-- 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 new file mode 100644 index 000000000..03df4428f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a35402a.ada @@ -0,0 +1,63 @@ +-- 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 new file mode 100644 index 000000000..bc50d2cb0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a35801f.ada @@ -0,0 +1,64 @@ +-- 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 new file mode 100644 index 000000000..2dd0c9b26 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a35902c.ada @@ -0,0 +1,51 @@ +-- 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 new file mode 100644 index 000000000..7db6aa6bb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a38106d.ada @@ -0,0 +1,99 @@ +-- 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 new file mode 100644 index 000000000..a0778acfd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a38106e.ada @@ -0,0 +1,99 @@ +-- 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 new file mode 100644 index 000000000..83e531b5e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a49027a.ada @@ -0,0 +1,85 @@ +-- 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 new file mode 100644 index 000000000..a27956d74 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a49027b.ada @@ -0,0 +1,159 @@ +-- 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 new file mode 100644 index 000000000..a10449e91 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a49027c.ada @@ -0,0 +1,70 @@ +-- 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 new file mode 100644 index 000000000..6a7b1ac24 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a54b01a.ada @@ -0,0 +1,119 @@ +-- 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 new file mode 100644 index 000000000..08d908ee9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a54b02a.ada @@ -0,0 +1,184 @@ +-- 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 new file mode 100644 index 000000000..75458075b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a55b12a.ada @@ -0,0 +1,147 @@ +-- 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 new file mode 100644 index 000000000..c2cc5acfd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a55b13a.ada @@ -0,0 +1,128 @@ +-- 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 new file mode 100644 index 000000000..617d95b68 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a55b14a.ada @@ -0,0 +1,112 @@ +-- 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 new file mode 100644 index 000000000..da793a8b3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a71004a.ada @@ -0,0 +1,130 @@ +-- 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 new file mode 100644 index 000000000..9595d0086 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a73001i.ada @@ -0,0 +1,73 @@ +-- 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 new file mode 100644 index 000000000..025e6db03 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a73001j.ada @@ -0,0 +1,78 @@ +-- 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 new file mode 100644 index 000000000..2bd4e09b4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a74105b.ada @@ -0,0 +1,78 @@ +-- 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 new file mode 100644 index 000000000..43afe5940 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a74106a.ada @@ -0,0 +1,168 @@ +-- 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 new file mode 100644 index 000000000..6f8963bff --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a74106b.ada @@ -0,0 +1,159 @@ +-- 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 new file mode 100644 index 000000000..fef020354 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a74106c.ada @@ -0,0 +1,155 @@ +-- 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 new file mode 100644 index 000000000..769e2e7e7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a74205e.ada @@ -0,0 +1,149 @@ +-- 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 new file mode 100644 index 000000000..23eb301e5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a74205f.ada @@ -0,0 +1,93 @@ +-- 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 new file mode 100644 index 000000000..da64073b3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a83009a.ada @@ -0,0 +1,198 @@ +-- 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 new file mode 100644 index 000000000..ebd9412be --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a83009b.ada @@ -0,0 +1,196 @@ +-- 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 new file mode 100644 index 000000000..45bdfad04 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a83a02a.ada @@ -0,0 +1,120 @@ +-- 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 new file mode 100644 index 000000000..7613f09ae --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a83a02b.ada @@ -0,0 +1,116 @@ +-- 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 new file mode 100644 index 000000000..3018fcd51 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a83a06a.ada @@ -0,0 +1,94 @@ +-- 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 new file mode 100644 index 000000000..5cdc30ecd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a83a08a.ada @@ -0,0 +1,102 @@ +-- 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; + + <> + + DECLARE + LBL : INTEGER := 1; + BEGIN + LBL := IDENT_INT (LBL); + PASSES := PASSES + 1; + END; + + <> + + BEGIN + DECLARE + TYPE STUFF IS (LBL, LBL_ONE, LBL_TWO); + ITEM : STUFF := LBL; + + FUNCTION LBLS (ITEM : STUFF) RETURN BOOLEAN IS + BEGIN + <> + 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; + + <> + + RESULT; + +END A83A08A; diff --git a/gcc/testsuite/ada/acats/tests/a/a83c01c.ada b/gcc/testsuite/ada/acats/tests/a/a83c01c.ada new file mode 100644 index 000000000..159f3cf86 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a83c01c.ada @@ -0,0 +1,83 @@ +-- 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 new file mode 100644 index 000000000..f50ce7761 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a83c01h.ada @@ -0,0 +1,99 @@ +-- 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 new file mode 100644 index 000000000..3a2ec2d3a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a83c01i.ada @@ -0,0 +1,112 @@ +-- 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 new file mode 100644 index 000000000..d86761d7e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a85007d.ada @@ -0,0 +1,156 @@ +-- 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 new file mode 100644 index 000000000..6b77ada5e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a85013b.ada @@ -0,0 +1,89 @@ +-- 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 new file mode 100644 index 000000000..3760e9180 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a87b59a.ada @@ -0,0 +1,250 @@ +-- 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 new file mode 100644 index 000000000..3826e0be4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a95001c.ada @@ -0,0 +1,74 @@ +-- 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 new file mode 100644 index 000000000..07c0032f0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a95074d.ada @@ -0,0 +1,82 @@ +-- 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 new file mode 100644 index 000000000..c25403296 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a97106a.ada @@ -0,0 +1,86 @@ +-- 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 new file mode 100644 index 000000000..d9822f462 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/a99006a.ada @@ -0,0 +1,66 @@ +-- 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 new file mode 100644 index 000000000..7feee2534 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/aa2010a.ada @@ -0,0 +1,199 @@ +-- 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 new file mode 100644 index 000000000..0f72c307b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/aa2012a.ada @@ -0,0 +1,70 @@ +-- 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 new file mode 100644 index 000000000..0e83ca556 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ac1015b.ada @@ -0,0 +1,81 @@ +-- 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 new file mode 100644 index 000000000..1b7099e85 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ac3106a.ada @@ -0,0 +1,216 @@ +-- 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 new file mode 100644 index 000000000..df535a945 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ac3206a.ada @@ -0,0 +1,120 @@ +-- 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 new file mode 100644 index 000000000..16057b9ad --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ac3207a.ada @@ -0,0 +1,92 @@ +-- 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 new file mode 100644 index 000000000..7e14d18b7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ad7001b.ada @@ -0,0 +1,66 @@ +-- 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 new file mode 100644 index 000000000..7b4658317 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ad7001c0.ada @@ -0,0 +1,65 @@ +-- 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 new file mode 100644 index 000000000..f7fd898a9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ad7001c1.ada @@ -0,0 +1,60 @@ +-- 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 new file mode 100644 index 000000000..0973e006c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ad7001d0.ada @@ -0,0 +1,60 @@ +-- 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 new file mode 100644 index 000000000..fea236add --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ad7001d1.ada @@ -0,0 +1,55 @@ +-- 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 new file mode 100644 index 000000000..1154fe30f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ad7006a.ada @@ -0,0 +1,47 @@ +-- 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 new file mode 100644 index 000000000..d0ee56872 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ad7101a.ada @@ -0,0 +1,51 @@ +-- 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 . + +-- 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 "); + + RESULT; + +END AD7101A; diff --git a/gcc/testsuite/ada/acats/tests/a/ad7101c.ada b/gcc/testsuite/ada/acats/tests/a/ad7101c.ada new file mode 100644 index 000000000..7b65d75a5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ad7101c.ada @@ -0,0 +1,50 @@ +-- 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 new file mode 100644 index 000000000..8f517fc20 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ad7102a.ada @@ -0,0 +1,50 @@ +-- 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 , 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 , 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 new file mode 100644 index 000000000..55fc0c154 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ad7103a.ada @@ -0,0 +1,50 @@ +-- 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 , 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 , 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 new file mode 100644 index 000000000..695eae3e2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ad7103c.ada @@ -0,0 +1,50 @@ +-- 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 , 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 , 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 new file mode 100644 index 000000000..204a6e0f5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ad7104a.ada @@ -0,0 +1,50 @@ +-- 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 , 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 " & + ", 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 new file mode 100644 index 000000000..e350277d8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ad7201a.ada @@ -0,0 +1,98 @@ +-- 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 +<> 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 new file mode 100644 index 000000000..47dd6b770 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ad7203b.ada @@ -0,0 +1,267 @@ +-- 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 new file mode 100644 index 000000000..d619750d3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ad7205b.ada @@ -0,0 +1,64 @@ +-- 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 new file mode 100644 index 000000000..93f666c3c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ad8011a.tst @@ -0,0 +1,64 @@ +-- 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 new file mode 100644 index 000000000..84b69d9b3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ada101a.ada @@ -0,0 +1,101 @@ +-- 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 new file mode 100644 index 000000000..4630d39c7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ae2113a.ada @@ -0,0 +1,120 @@ +-- 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 new file mode 100644 index 000000000..969813179 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ae2113b.ada @@ -0,0 +1,120 @@ +-- 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 new file mode 100644 index 000000000..0a110cf14 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ae3002g.ada @@ -0,0 +1,47 @@ +-- 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 new file mode 100644 index 000000000..d050ee0e9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ae3101a.ada @@ -0,0 +1,135 @@ +-- 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 new file mode 100644 index 000000000..a18b1a003 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ae3702a.ada @@ -0,0 +1,59 @@ +-- 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 new file mode 100644 index 000000000..5866120b0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/a/ae3709a.ada @@ -0,0 +1,56 @@ +-- 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 new file mode 100644 index 000000000..55fa97ce9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c23001a.ada @@ -0,0 +1,64 @@ +-- 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 new file mode 100644 index 000000000..26fe9577c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c23003a.tst @@ -0,0 +1,104 @@ +-- 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 new file mode 100644 index 000000000..00249b68d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c23003b.tst @@ -0,0 +1,103 @@ +-- 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 new file mode 100644 index 000000000..5769937ad --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c23003g.tst @@ -0,0 +1,129 @@ +-- 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 new file mode 100644 index 000000000..7439cf356 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c23003i.tst @@ -0,0 +1,71 @@ +-- 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 new file mode 100644 index 000000000..bad6b4e3a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c23006a.ada @@ -0,0 +1,48 @@ +-- 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 new file mode 100644 index 000000000..61ecb77b2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c23006b.ada @@ -0,0 +1,63 @@ +-- 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 new file mode 100644 index 000000000..ddfe5a672 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c23006c.ada @@ -0,0 +1,75 @@ +-- 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 new file mode 100644 index 000000000..0df360f82 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c23006d.ada @@ -0,0 +1,74 @@ +-- 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 new file mode 100644 index 000000000..cd49ba586 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c23006e.ada @@ -0,0 +1,95 @@ +-- 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 new file mode 100644 index 000000000..6848ce97e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c23006f.ada @@ -0,0 +1,57 @@ +-- 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 new file mode 100644 index 000000000..ee3ad2896 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c23006g.ada @@ -0,0 +1,86 @@ +-- 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 new file mode 100644 index 000000000..5a9b06669 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c24002d.ada @@ -0,0 +1,85 @@ +-- 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 new file mode 100644 index 000000000..61c6fa2a0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c24003a.ada @@ -0,0 +1,61 @@ +-- 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 new file mode 100644 index 000000000..c38597356 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c24003b.ada @@ -0,0 +1,77 @@ +-- 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 new file mode 100644 index 000000000..1eb8dd2c8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c24003c.ada @@ -0,0 +1,79 @@ +-- 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 new file mode 100644 index 000000000..fcecd0673 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c24106a.ada @@ -0,0 +1,63 @@ +-- 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 new file mode 100644 index 000000000..65c3d2186 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c24202d.ada @@ -0,0 +1,73 @@ +-- 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 new file mode 100644 index 000000000..a97bb866d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c24203a.ada @@ -0,0 +1,110 @@ +-- 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 new file mode 100644 index 000000000..8a56bf1e5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c24203b.ada @@ -0,0 +1,113 @@ +-- 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 new file mode 100644 index 000000000..ca7e17f7c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c24207a.ada @@ -0,0 +1,65 @@ +-- 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 new file mode 100644 index 000000000..f04e0332c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c24211a.ada @@ -0,0 +1,87 @@ +-- 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 new file mode 100644 index 000000000..fd5334359 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c250001.aw @@ -0,0 +1,167 @@ +-- 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, () 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 new file mode 100644 index 000000000..fe2248155 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c250002.aw @@ -0,0 +1,213 @@ +-- 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 () 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 new file mode 100644 index 000000000..bb27be723 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c25001a.ada @@ -0,0 +1,211 @@ +-- 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 new file mode 100644 index 000000000..d82547cc7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c25001b.ada @@ -0,0 +1,160 @@ +-- 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 new file mode 100644 index 000000000..b4e8ce6b2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c26006a.ada @@ -0,0 +1,53 @@ +-- 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 new file mode 100644 index 000000000..89bb549da --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c26008a.ada @@ -0,0 +1,51 @@ +-- 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 new file mode 100644 index 000000000..27b8fe0a2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c2a001a.ada @@ -0,0 +1,60 @@ +-- 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 new file mode 100644 index 000000000..ea1f1baae --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c2a001b.ada @@ -0,0 +1,59 @@ +-- 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 new file mode 100644 index 000000000..db3c98d59 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c2a001c.ada @@ -0,0 +1,63 @@ +-- 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 new file mode 100644 index 000000000..cd7cd5998 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c2a002a.ada @@ -0,0 +1,111 @@ +-- 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 new file mode 100644 index 000000000..70690c7dd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c2a008a.ada @@ -0,0 +1,66 @@ +-- 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 new file mode 100644 index 000000000..572e4ce55 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c2/c2a021b.ada @@ -0,0 +1,44 @@ +-- 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 new file mode 100644 index 000000000..5d90b62b0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c32001a.ada @@ -0,0 +1,152 @@ +-- 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 new file mode 100644 index 000000000..c4d5acc32 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c32001b.ada @@ -0,0 +1,249 @@ +-- 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 new file mode 100644 index 000000000..bc70568a7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c32001c.ada @@ -0,0 +1,125 @@ +-- 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 new file mode 100644 index 000000000..e8a6a20e0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c32001d.ada @@ -0,0 +1,99 @@ +-- 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 new file mode 100644 index 000000000..253acc51f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c32001e.ada @@ -0,0 +1,253 @@ +-- 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 new file mode 100644 index 000000000..fd4ed0926 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c32107a.ada @@ -0,0 +1,363 @@ +-- 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 new file mode 100644 index 000000000..31295356b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c32107c.ada @@ -0,0 +1,164 @@ +-- 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 new file mode 100644 index 000000000..47423588e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c32108a.ada @@ -0,0 +1,78 @@ +-- 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 new file mode 100644 index 000000000..10895788d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c32108b.ada @@ -0,0 +1,80 @@ +-- 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 new file mode 100644 index 000000000..3cbce0940 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c32111a.ada @@ -0,0 +1,282 @@ +-- 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 new file mode 100644 index 000000000..85ff55e5d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c32111b.ada @@ -0,0 +1,282 @@ +-- 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 new file mode 100644 index 000000000..e2aeeb6d7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c32112b.ada @@ -0,0 +1,267 @@ +-- 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 new file mode 100644 index 000000000..60f8d6690 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c32113a.ada @@ -0,0 +1,534 @@ +-- 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 new file mode 100644 index 000000000..826bd2434 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c32115a.ada @@ -0,0 +1,338 @@ +-- 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 new file mode 100644 index 000000000..d1819c569 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c32115b.ada @@ -0,0 +1,376 @@ +-- 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 new file mode 100644 index 000000000..218896d67 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c330001.a @@ -0,0 +1,354 @@ +-- 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 new file mode 100644 index 000000000..1403d5557 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c330002.a @@ -0,0 +1,326 @@ +-- 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 new file mode 100644 index 000000000..21d657373 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c332001.a @@ -0,0 +1,226 @@ +-- 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 new file mode 100644 index 000000000..dce98bdb0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c340001.a @@ -0,0 +1,470 @@ +-- 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 new file mode 100644 index 000000000..c66d7ddbc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34001a.ada @@ -0,0 +1,186 @@ +-- 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 new file mode 100644 index 000000000..a4509db4a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34001c.ada @@ -0,0 +1,150 @@ +-- 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 new file mode 100644 index 000000000..7b9832898 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34001d.ada @@ -0,0 +1,209 @@ +-- 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 new file mode 100644 index 000000000..6226e7291 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34001f.ada @@ -0,0 +1,119 @@ +-- 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 new file mode 100644 index 000000000..8b5690e20 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34002a.ada @@ -0,0 +1,265 @@ +-- 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 new file mode 100644 index 000000000..a14459d33 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34002c.ada @@ -0,0 +1,152 @@ +-- 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 new file mode 100644 index 000000000..ed37d0585 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34003a.ada @@ -0,0 +1,260 @@ +-- 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 new file mode 100644 index 000000000..9de3574af --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34003c.ada @@ -0,0 +1,156 @@ +-- 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 new file mode 100644 index 000000000..735776a19 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34004a.ada @@ -0,0 +1,267 @@ +-- 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 new file mode 100644 index 000000000..d3b699f77 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34004c.ada @@ -0,0 +1,191 @@ +-- 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 new file mode 100644 index 000000000..5da6fc939 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34005a.ada @@ -0,0 +1,410 @@ +-- 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 new file mode 100644 index 000000000..2af86afe1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34005c.ada @@ -0,0 +1,195 @@ +-- 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 new file mode 100644 index 000000000..b549be35d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34005d.ada @@ -0,0 +1,425 @@ +-- 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 new file mode 100644 index 000000000..1971bf4e8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34005f.ada @@ -0,0 +1,195 @@ +-- 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 new file mode 100644 index 000000000..fd8f8ffbf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34005g.ada @@ -0,0 +1,423 @@ +-- 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 new file mode 100644 index 000000000..580880e25 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34005i.ada @@ -0,0 +1,195 @@ +-- 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 new file mode 100644 index 000000000..67910aab8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34005j.ada @@ -0,0 +1,482 @@ +-- 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 new file mode 100644 index 000000000..2aba733f3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34005l.ada @@ -0,0 +1,195 @@ +-- 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 new file mode 100644 index 000000000..51d319226 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34005m.ada @@ -0,0 +1,353 @@ +-- 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 new file mode 100644 index 000000000..a45d5ddb2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34005o.ada @@ -0,0 +1,277 @@ +-- 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 new file mode 100644 index 000000000..31e67a72e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34005p.ada @@ -0,0 +1,405 @@ +-- 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 new file mode 100644 index 000000000..8b36d59a3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34005r.ada @@ -0,0 +1,346 @@ +-- 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 new file mode 100644 index 000000000..515816665 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34005s.ada @@ -0,0 +1,404 @@ +-- 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 new file mode 100644 index 000000000..ed77f3bfa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34005u.ada @@ -0,0 +1,408 @@ +-- 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 new file mode 100644 index 000000000..cb59125b4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34005v.ada @@ -0,0 +1,336 @@ +-- 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 new file mode 100644 index 000000000..c5d4675e2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34006a.ada @@ -0,0 +1,151 @@ +-- 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 new file mode 100644 index 000000000..614a830be --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34006d.ada @@ -0,0 +1,238 @@ +-- 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 new file mode 100644 index 000000000..3ee3745ac --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34006f.ada @@ -0,0 +1,228 @@ +-- 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 new file mode 100644 index 000000000..ebb6c51ed --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34006g.ada @@ -0,0 +1,199 @@ +-- 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 new file mode 100644 index 000000000..597bf63c5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34006j.ada @@ -0,0 +1,311 @@ +-- 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 new file mode 100644 index 000000000..65a21f934 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34006l.ada @@ -0,0 +1,345 @@ +-- 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 new file mode 100644 index 000000000..d75c8cc45 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34007a.ada @@ -0,0 +1,181 @@ +-- 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 new file mode 100644 index 000000000..9378a2bbc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34007d.ada @@ -0,0 +1,266 @@ +-- 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 new file mode 100644 index 000000000..0e9222b58 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34007f.ada @@ -0,0 +1,163 @@ +-- 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 new file mode 100644 index 000000000..85c0f2ab9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34007g.ada @@ -0,0 +1,350 @@ +-- 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 new file mode 100644 index 000000000..55bc2c494 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34007i.ada @@ -0,0 +1,213 @@ +-- 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 new file mode 100644 index 000000000..1ce054cb7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34007j.ada @@ -0,0 +1,258 @@ +-- 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 new file mode 100644 index 000000000..e266f575c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34007m.ada @@ -0,0 +1,191 @@ +-- 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 new file mode 100644 index 000000000..a6d85b0d6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34007p.ada @@ -0,0 +1,283 @@ +-- 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 new file mode 100644 index 000000000..096d84527 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34007r.ada @@ -0,0 +1,218 @@ +-- 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 new file mode 100644 index 000000000..54a2f3344 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34007s.ada @@ -0,0 +1,299 @@ +-- 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 new file mode 100644 index 000000000..05c699025 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34007u.ada @@ -0,0 +1,266 @@ +-- 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 new file mode 100644 index 000000000..8ee4bf829 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34007v.ada @@ -0,0 +1,183 @@ +-- 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 new file mode 100644 index 000000000..5af4e3a56 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34008a.ada @@ -0,0 +1,226 @@ +-- 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 new file mode 100644 index 000000000..6cda3277f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34009a.ada @@ -0,0 +1,134 @@ +-- 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 new file mode 100644 index 000000000..c65441f57 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34009d.ada @@ -0,0 +1,226 @@ +-- 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 new file mode 100644 index 000000000..63716c564 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34009f.ada @@ -0,0 +1,256 @@ +-- 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 new file mode 100644 index 000000000..a225347a7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34009g.ada @@ -0,0 +1,137 @@ +-- 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 new file mode 100644 index 000000000..f095fad15 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34009j.ada @@ -0,0 +1,225 @@ +-- 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 new file mode 100644 index 000000000..71a02f28b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34009l.ada @@ -0,0 +1,270 @@ +-- 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 new file mode 100644 index 000000000..47e260090 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34011b.ada @@ -0,0 +1,343 @@ +-- 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 new file mode 100644 index 000000000..020b79b42 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34012a.ada @@ -0,0 +1,136 @@ +-- 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 new file mode 100644 index 000000000..e2a917e6d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34014a.ada @@ -0,0 +1,256 @@ +-- 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 new file mode 100644 index 000000000..9dd17e22f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34014c.ada @@ -0,0 +1,259 @@ +-- 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 new file mode 100644 index 000000000..0c7fea237 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34014e.ada @@ -0,0 +1,257 @@ +-- 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 new file mode 100644 index 000000000..5be7f5008 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34014g.ada @@ -0,0 +1,107 @@ +-- 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 new file mode 100644 index 000000000..b1bf56c31 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34014h.ada @@ -0,0 +1,208 @@ +-- 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 new file mode 100644 index 000000000..321a784e5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34014n.ada @@ -0,0 +1,256 @@ +-- 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 new file mode 100644 index 000000000..161fbbbff --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34014p.ada @@ -0,0 +1,258 @@ +-- 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 new file mode 100644 index 000000000..ab21b4842 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34014r.ada @@ -0,0 +1,257 @@ +-- 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 new file mode 100644 index 000000000..ddf22c6be --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34014t.ada @@ -0,0 +1,107 @@ +-- 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 new file mode 100644 index 000000000..209b06d1f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34014u.ada @@ -0,0 +1,212 @@ +-- 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 new file mode 100644 index 000000000..d039337fc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c34018a.ada @@ -0,0 +1,154 @@ +-- 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 new file mode 100644 index 000000000..108a30b5f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c340a01.a @@ -0,0 +1,165 @@ +-- 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 new file mode 100644 index 000000000..2dd8f175c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c340a02.a @@ -0,0 +1,221 @@ +-- 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 new file mode 100644 index 000000000..34a1eeeaa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c341a01.a @@ -0,0 +1,117 @@ +-- 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 new file mode 100644 index 000000000..4fa9842bf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c341a02.a @@ -0,0 +1,145 @@ +-- 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 new file mode 100644 index 000000000..0911e636d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c341a03.a @@ -0,0 +1,140 @@ +-- 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 new file mode 100644 index 000000000..d7392568e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c341a04.a @@ -0,0 +1,141 @@ +-- 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 new file mode 100644 index 000000000..c384683fd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35003a.ada @@ -0,0 +1,234 @@ +-- 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 new file mode 100644 index 000000000..3eebde438 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35003b.ada @@ -0,0 +1,217 @@ +-- 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 new file mode 100644 index 000000000..c5241ee80 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35003d.ada @@ -0,0 +1,92 @@ +-- 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 new file mode 100644 index 000000000..a5ca875e4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35102a.ada @@ -0,0 +1,364 @@ +-- 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/c354002.a b/gcc/testsuite/ada/acats/tests/c3/c354002.a new file mode 100644 index 000000000..3129182b7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c354002.a @@ -0,0 +1,335 @@ +-- +-- 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 new file mode 100644 index 000000000..1f607a7e6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c354003.a @@ -0,0 +1,211 @@ +-- 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 new file mode 100644 index 000000000..ffb819046 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35502a.ada @@ -0,0 +1,71 @@ +-- 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 new file mode 100644 index 000000000..aff813514 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35502b.ada @@ -0,0 +1,81 @@ +-- 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 new file mode 100644 index 000000000..a635e68fb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35502c.ada @@ -0,0 +1,318 @@ +-- 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 new file mode 100644 index 000000000..7da988197 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35502d.tst @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..16e3cf098 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35502e.ada @@ -0,0 +1,155 @@ +-- 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 new file mode 100644 index 000000000..30be23e47 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35502f.tst @@ -0,0 +1,89 @@ +-- 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 new file mode 100644 index 000000000..aff9fb399 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35502g.ada @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..640e2e9de --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35502h.ada @@ -0,0 +1,82 @@ +-- 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 new file mode 100644 index 000000000..a9116d60b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35502i.ada @@ -0,0 +1,91 @@ +-- 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 new file mode 100644 index 000000000..37d17b259 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35502j.ada @@ -0,0 +1,92 @@ +-- 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 new file mode 100644 index 000000000..716521ba9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35502k.ada @@ -0,0 +1,174 @@ +-- 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 new file mode 100644 index 000000000..768c1435a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35502l.ada @@ -0,0 +1,152 @@ +-- 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 new file mode 100644 index 000000000..754ecc52c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35502m.ada @@ -0,0 +1,177 @@ +-- 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 new file mode 100644 index 000000000..780120dbb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35502n.ada @@ -0,0 +1,158 @@ +-- 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 new file mode 100644 index 000000000..561e1e9aa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35502o.ada @@ -0,0 +1,52 @@ +-- 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 new file mode 100644 index 000000000..1dfef9ab0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35502p.ada @@ -0,0 +1,122 @@ +-- 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 new file mode 100644 index 000000000..b9daf25f9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35503a.ada @@ -0,0 +1,80 @@ +-- 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 new file mode 100644 index 000000000..f1bb5af0b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35503b.ada @@ -0,0 +1,87 @@ +-- 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 new file mode 100644 index 000000000..331c76cc4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35503c.ada @@ -0,0 +1,543 @@ +-- 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 new file mode 100644 index 000000000..b15e1ab0f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35503d.tst @@ -0,0 +1,97 @@ +-- 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 new file mode 100644 index 000000000..0f326e1e5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35503e.ada @@ -0,0 +1,212 @@ +-- 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 new file mode 100644 index 000000000..f68669aaf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35503f.tst @@ -0,0 +1,132 @@ +-- 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 new file mode 100644 index 000000000..2004e457a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35503g.ada @@ -0,0 +1,113 @@ +-- 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 new file mode 100644 index 000000000..e1410673d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35503h.ada @@ -0,0 +1,94 @@ +-- 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 new file mode 100644 index 000000000..e05021c6b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35503k.ada @@ -0,0 +1,120 @@ +-- 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 new file mode 100644 index 000000000..33d571d9d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35503l.ada @@ -0,0 +1,98 @@ +-- 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 new file mode 100644 index 000000000..57d288f37 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35503o.ada @@ -0,0 +1,125 @@ +-- 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 new file mode 100644 index 000000000..28ecac33b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35503p.ada @@ -0,0 +1,113 @@ +-- 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 new file mode 100644 index 000000000..6c2c59a1d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35504a.ada @@ -0,0 +1,63 @@ +-- 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 new file mode 100644 index 000000000..644b1d643 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35504b.ada @@ -0,0 +1,85 @@ +-- 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 new file mode 100644 index 000000000..52bf7f211 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35505c.ada @@ -0,0 +1,102 @@ +-- 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 new file mode 100644 index 000000000..0da82dae9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35505e.ada @@ -0,0 +1,144 @@ +-- 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 new file mode 100644 index 000000000..b8d4acc1b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35505f.ada @@ -0,0 +1,164 @@ +-- 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 new file mode 100644 index 000000000..0a6776560 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35507a.ada @@ -0,0 +1,88 @@ +-- 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 new file mode 100644 index 000000000..b50c4c0dc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35507b.ada @@ -0,0 +1,96 @@ +-- 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 new file mode 100644 index 000000000..386e5a36f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35507c.ada @@ -0,0 +1,360 @@ +-- 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 new file mode 100644 index 000000000..93979902c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35507e.ada @@ -0,0 +1,194 @@ +-- 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 new file mode 100644 index 000000000..a1d8ecec4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35507g.ada @@ -0,0 +1,96 @@ +-- 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 new file mode 100644 index 000000000..053b20c71 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35507h.ada @@ -0,0 +1,89 @@ +-- 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 new file mode 100644 index 000000000..e2318d7b2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35507i.ada @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..9e9e89856 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35507j.ada @@ -0,0 +1,93 @@ +-- 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 new file mode 100644 index 000000000..b26399234 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35507k.ada @@ -0,0 +1,224 @@ +-- 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 new file mode 100644 index 000000000..a259c74f9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35507l.ada @@ -0,0 +1,101 @@ +-- 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 new file mode 100644 index 000000000..e76178c6c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35507m.ada @@ -0,0 +1,159 @@ +-- 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 new file mode 100644 index 000000000..1e5e48a3a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35507n.ada @@ -0,0 +1,108 @@ +-- 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 new file mode 100644 index 000000000..723a5ea11 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35507o.ada @@ -0,0 +1,120 @@ +-- 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 new file mode 100644 index 000000000..85c8c2781 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35507p.ada @@ -0,0 +1,94 @@ +-- 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 new file mode 100644 index 000000000..5e4f72da9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35508a.ada @@ -0,0 +1,74 @@ +-- 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 new file mode 100644 index 000000000..b0339faec --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35508b.ada @@ -0,0 +1,79 @@ +-- 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 new file mode 100644 index 000000000..88ca20ad2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35508c.ada @@ -0,0 +1,195 @@ +-- 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 new file mode 100644 index 000000000..584ccfec8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35508e.ada @@ -0,0 +1,192 @@ +-- 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 new file mode 100644 index 000000000..dd546d2b9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35508g.ada @@ -0,0 +1,105 @@ +-- 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 new file mode 100644 index 000000000..2b89a29ed --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35508h.ada @@ -0,0 +1,116 @@ +-- 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 new file mode 100644 index 000000000..338397a5b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35508k.ada @@ -0,0 +1,125 @@ +-- 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 new file mode 100644 index 000000000..cba30e237 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35508l.ada @@ -0,0 +1,132 @@ +-- 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 new file mode 100644 index 000000000..ff1eb67e6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35508o.ada @@ -0,0 +1,98 @@ +-- 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 new file mode 100644 index 000000000..8ee3e8848 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35508p.ada @@ -0,0 +1,131 @@ +-- 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 new file mode 100644 index 000000000..6980f3c9f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35703a.ada @@ -0,0 +1,142 @@ +-- 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 new file mode 100644 index 000000000..e1e8532f4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35704a.ada @@ -0,0 +1,60 @@ +-- 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 new file mode 100644 index 000000000..7efae7783 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35704b.ada @@ -0,0 +1,62 @@ +-- 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 new file mode 100644 index 000000000..2b0fe3b32 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35704c.ada @@ -0,0 +1,62 @@ +-- 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 new file mode 100644 index 000000000..0afd81de1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35704d.ada @@ -0,0 +1,70 @@ +-- 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 new file mode 100644 index 000000000..5ee825904 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35801d.ada @@ -0,0 +1,79 @@ +-- 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 new file mode 100644 index 000000000..c09fe5894 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35902d.ada @@ -0,0 +1,121 @@ +-- 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 new file mode 100644 index 000000000..8b3bfbba6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35904a.ada @@ -0,0 +1,103 @@ +-- 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 new file mode 100644 index 000000000..cff7d2ec8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35904b.ada @@ -0,0 +1,136 @@ +-- 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 new file mode 100644 index 000000000..5ebee358d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35a02a.ada @@ -0,0 +1,75 @@ +-- 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 new file mode 100644 index 000000000..c850249d4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35a05a.ada @@ -0,0 +1,153 @@ +-- 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 new file mode 100644 index 000000000..9b07671f5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35a05d.ada @@ -0,0 +1,153 @@ +-- 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 new file mode 100644 index 000000000..4c1102d58 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35a05n.ada @@ -0,0 +1,160 @@ +-- 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 new file mode 100644 index 000000000..3a88ffb48 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35a05q.ada @@ -0,0 +1,184 @@ +-- 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 new file mode 100644 index 000000000..ae7baf6fa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35a07a.ada @@ -0,0 +1,129 @@ +-- 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 new file mode 100644 index 000000000..1a293cc83 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35a07d.ada @@ -0,0 +1,191 @@ +-- 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 new file mode 100644 index 000000000..1750bfa12 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c35a08b.ada @@ -0,0 +1,91 @@ +-- 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 new file mode 100644 index 000000000..95cb3ef07 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c360002.a @@ -0,0 +1,268 @@ +-- 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 new file mode 100644 index 000000000..4cdaccd0b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36104a.ada @@ -0,0 +1,359 @@ +-- 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 new file mode 100644 index 000000000..9c896b9df --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36104b.ada @@ -0,0 +1,421 @@ +-- 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 new file mode 100644 index 000000000..9c9e6cf13 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36172a.ada @@ -0,0 +1,250 @@ +-- 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 new file mode 100644 index 000000000..bf689b425 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36172b.ada @@ -0,0 +1,161 @@ +-- 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 new file mode 100644 index 000000000..4d97fa13a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36172c.ada @@ -0,0 +1,58 @@ +-- 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 new file mode 100644 index 000000000..667512abc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36174a.ada @@ -0,0 +1,118 @@ +-- 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 new file mode 100644 index 000000000..553809605 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36180a.ada @@ -0,0 +1,136 @@ +-- 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 new file mode 100644 index 000000000..03ca89e77 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36202c.ada @@ -0,0 +1,87 @@ +-- 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 new file mode 100644 index 000000000..f3f7e2bc7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36203a.ada @@ -0,0 +1,76 @@ +-- 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 new file mode 100644 index 000000000..4a4c37429 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36204a.ada @@ -0,0 +1,142 @@ +-- 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 new file mode 100644 index 000000000..82f6b9369 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36204b.ada @@ -0,0 +1,229 @@ +-- 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 new file mode 100644 index 000000000..171369528 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36204c.ada @@ -0,0 +1,221 @@ +-- 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 new file mode 100644 index 000000000..afdadbf53 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36204d.ada @@ -0,0 +1,598 @@ +-- 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 new file mode 100644 index 000000000..8c1f683be --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36205a.ada @@ -0,0 +1,212 @@ +-- 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 new file mode 100644 index 000000000..b29816ca1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36205b.ada @@ -0,0 +1,169 @@ +-- 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 new file mode 100644 index 000000000..b11363baa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36205c.ada @@ -0,0 +1,165 @@ +-- 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 new file mode 100644 index 000000000..f03f75dd0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36205d.ada @@ -0,0 +1,180 @@ +-- 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 new file mode 100644 index 000000000..f165a2894 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36205e.ada @@ -0,0 +1,164 @@ +-- 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 new file mode 100644 index 000000000..22e1c1602 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36205f.ada @@ -0,0 +1,165 @@ +-- 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 new file mode 100644 index 000000000..93f5a2e54 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36205g.ada @@ -0,0 +1,165 @@ +-- 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 new file mode 100644 index 000000000..00303bc80 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36205h.ada @@ -0,0 +1,166 @@ +-- 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 new file mode 100644 index 000000000..d61b3aa1c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36205i.ada @@ -0,0 +1,167 @@ +-- 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 new file mode 100644 index 000000000..a0d8218a6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36205j.ada @@ -0,0 +1,180 @@ +-- 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 new file mode 100644 index 000000000..44a80767f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36205k.ada @@ -0,0 +1,173 @@ +-- 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 new file mode 100644 index 000000000..9a1126e34 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36205l.ada @@ -0,0 +1,288 @@ +-- 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 new file mode 100644 index 000000000..9f93a7f3b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36301a.ada @@ -0,0 +1,149 @@ +-- 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 new file mode 100644 index 000000000..4153db2a5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36301b.ada @@ -0,0 +1,55 @@ +-- 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 new file mode 100644 index 000000000..1e7159879 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36302a.ada @@ -0,0 +1,53 @@ +-- 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 new file mode 100644 index 000000000..a561f3fdd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36304a.ada @@ -0,0 +1,91 @@ +-- 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 new file mode 100644 index 000000000..09adbe156 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c36305a.ada @@ -0,0 +1,117 @@ +-- 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 new file mode 100644 index 000000000..fbb61cf39 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37002a.ada @@ -0,0 +1,79 @@ +-- 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 new file mode 100644 index 000000000..5378f4ddd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37003a.ada @@ -0,0 +1,198 @@ +-- 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 new file mode 100644 index 000000000..49ebdc0ed --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37003b.ada @@ -0,0 +1,66 @@ +-- 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 new file mode 100644 index 000000000..0983fe00e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37005a.ada @@ -0,0 +1,92 @@ +-- 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 new file mode 100644 index 000000000..ac926d1f4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37006a.ada @@ -0,0 +1,272 @@ +-- 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 new file mode 100644 index 000000000..5546ae0ff --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37008a.ada @@ -0,0 +1,270 @@ +-- 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 new file mode 100644 index 000000000..369f08cf5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37008b.ada @@ -0,0 +1,232 @@ +-- 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 new file mode 100644 index 000000000..bdb3d810c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37009a.ada @@ -0,0 +1,195 @@ +-- 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 new file mode 100644 index 000000000..64ba42018 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37010a.ada @@ -0,0 +1,140 @@ +-- 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 new file mode 100644 index 000000000..aa94b2dec --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37010b.ada @@ -0,0 +1,164 @@ +-- 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 new file mode 100644 index 000000000..f6823570b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c371001.a @@ -0,0 +1,388 @@ +-- 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 new file mode 100644 index 000000000..ea532550c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c371002.a @@ -0,0 +1,364 @@ +-- 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 new file mode 100644 index 000000000..c4a8345f6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c371003.a @@ -0,0 +1,474 @@ +-- 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 new file mode 100644 index 000000000..13c4e5c9c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37102b.ada @@ -0,0 +1,109 @@ +-- 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 new file mode 100644 index 000000000..10878357f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37103a.ada @@ -0,0 +1,83 @@ +-- 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 new file mode 100644 index 000000000..b8f836e73 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37105a.ada @@ -0,0 +1,55 @@ +-- 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 new file mode 100644 index 000000000..a007f7c31 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37107a.ada @@ -0,0 +1,154 @@ +-- 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 new file mode 100644 index 000000000..9d71e9a72 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37108b.ada @@ -0,0 +1,247 @@ +-- 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 new file mode 100644 index 000000000..d37c794cb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37206a.ada @@ -0,0 +1,65 @@ +-- 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 new file mode 100644 index 000000000..e02724088 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37207a.ada @@ -0,0 +1,230 @@ +-- 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 new file mode 100644 index 000000000..a83b7ef19 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37208a.ada @@ -0,0 +1,172 @@ +-- 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 new file mode 100644 index 000000000..3fc4e651b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37208b.ada @@ -0,0 +1,120 @@ +-- 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 new file mode 100644 index 000000000..52d25077c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37209a.ada @@ -0,0 +1,145 @@ +-- 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 new file mode 100644 index 000000000..9b1bfc8d4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37209b.ada @@ -0,0 +1,194 @@ +-- 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 new file mode 100644 index 000000000..8542bb5b2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37210a.ada @@ -0,0 +1,116 @@ +-- 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 new file mode 100644 index 000000000..4b718a9ec --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37211a.ada @@ -0,0 +1,242 @@ +-- 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 new file mode 100644 index 000000000..fbc3591ef --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37211b.ada @@ -0,0 +1,495 @@ +-- 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 new file mode 100644 index 000000000..ba15964d0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37211c.ada @@ -0,0 +1,426 @@ +-- 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 new file mode 100644 index 000000000..8d623c8bd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37211d.ada @@ -0,0 +1,102 @@ +-- 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 new file mode 100644 index 000000000..c4b12fa44 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37211e.ada @@ -0,0 +1,233 @@ +-- 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 new file mode 100644 index 000000000..2117ece0b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37213b.ada @@ -0,0 +1,241 @@ +-- 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 new file mode 100644 index 000000000..dc2d67299 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37213d.ada @@ -0,0 +1,240 @@ +-- 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 new file mode 100644 index 000000000..3699c1a97 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37213f.ada @@ -0,0 +1,379 @@ +-- 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 new file mode 100644 index 000000000..e83ae07ca --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37213h.ada @@ -0,0 +1,457 @@ +-- 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 new file mode 100644 index 000000000..f09d853c2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37213j.ada @@ -0,0 +1,320 @@ +-- 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 new file mode 100644 index 000000000..d5b5dc38d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37213k.ada @@ -0,0 +1,324 @@ +-- 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 new file mode 100644 index 000000000..07bd124f4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37213l.ada @@ -0,0 +1,329 @@ +-- 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 new file mode 100644 index 000000000..408804e17 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37215b.ada @@ -0,0 +1,203 @@ +-- 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 new file mode 100644 index 000000000..3eefc5378 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37215d.ada @@ -0,0 +1,202 @@ +-- 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 new file mode 100644 index 000000000..1f34c4eae --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37215f.ada @@ -0,0 +1,313 @@ +-- 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 new file mode 100644 index 000000000..c98180a3c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37215h.ada @@ -0,0 +1,345 @@ +-- 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 new file mode 100644 index 000000000..bf0a9b4b4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37217a.ada @@ -0,0 +1,128 @@ +-- 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 new file mode 100644 index 000000000..77a9d8996 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37217b.ada @@ -0,0 +1,132 @@ +-- 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 new file mode 100644 index 000000000..f6fee5c17 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37217c.ada @@ -0,0 +1,100 @@ +-- 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 new file mode 100644 index 000000000..e521671e2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37304a.ada @@ -0,0 +1,92 @@ +-- 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 new file mode 100644 index 000000000..0282fa90e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37305a.ada @@ -0,0 +1,82 @@ +-- 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 new file mode 100644 index 000000000..f50fe0195 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37306a.ada @@ -0,0 +1,70 @@ +-- 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 new file mode 100644 index 000000000..316c0e8a8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37309a.ada @@ -0,0 +1,74 @@ +-- 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 new file mode 100644 index 000000000..dfa3748a9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37310a.ada @@ -0,0 +1,124 @@ +-- 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 new file mode 100644 index 000000000..f34eb7cb3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37312a.ada @@ -0,0 +1,87 @@ +-- 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 new file mode 100644 index 000000000..ec21d745f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37402a.ada @@ -0,0 +1,253 @@ +-- 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 new file mode 100644 index 000000000..baa65f57b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37403a.ada @@ -0,0 +1,186 @@ +-- 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 new file mode 100644 index 000000000..006d4492b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37404a.ada @@ -0,0 +1,168 @@ +--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 new file mode 100644 index 000000000..d7a03ecd6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37404b.ada @@ -0,0 +1,148 @@ +--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 new file mode 100644 index 000000000..187033773 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37405a.ada @@ -0,0 +1,161 @@ +-- 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 new file mode 100644 index 000000000..d11574b61 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c37411a.ada @@ -0,0 +1,82 @@ +-- 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 new file mode 100644 index 000000000..0ebe4d31c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c380001.a @@ -0,0 +1,128 @@ +-- 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 new file mode 100644 index 000000000..ae58676cb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c380002.a @@ -0,0 +1,72 @@ +-- 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 new file mode 100644 index 000000000..451d17703 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c380003.a @@ -0,0 +1,223 @@ +-- 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 new file mode 100644 index 000000000..f83728b5f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c380004.a @@ -0,0 +1,385 @@ +-- 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 new file mode 100644 index 000000000..33d6eba8a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c38002a.ada @@ -0,0 +1,420 @@ +-- 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 new file mode 100644 index 000000000..9a51c9b8a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c38002b.ada @@ -0,0 +1,123 @@ +-- 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 new file mode 100644 index 000000000..75a83a8a8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c38005a.ada @@ -0,0 +1,170 @@ +-- 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 new file mode 100644 index 000000000..1c2770425 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c38005b.ada @@ -0,0 +1,98 @@ +-- 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 new file mode 100644 index 000000000..5512ecbbf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c38005c.ada @@ -0,0 +1,156 @@ +-- 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 new file mode 100644 index 000000000..a4f0c90db --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c38006a.ada @@ -0,0 +1,50 @@ +-- 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 new file mode 100644 index 000000000..32649abcd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c38102a.ada @@ -0,0 +1,158 @@ +-- 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 new file mode 100644 index 000000000..c9e4bc272 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c38102b.ada @@ -0,0 +1,56 @@ +-- 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 new file mode 100644 index 000000000..a4128ae98 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c38102c.ada @@ -0,0 +1,60 @@ +-- 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 new file mode 100644 index 000000000..60361272e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c38102d.ada @@ -0,0 +1,54 @@ +-- 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 new file mode 100644 index 000000000..6ffec0599 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c38102e.ada @@ -0,0 +1,164 @@ +-- 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 new file mode 100644 index 000000000..f5f2873af --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c38104a.ada @@ -0,0 +1,97 @@ +-- 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 new file mode 100644 index 000000000..75a2492d6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c38107a.ada @@ -0,0 +1,105 @@ +-- 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 new file mode 100644 index 000000000..8e74581f3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c38107b.ada @@ -0,0 +1,194 @@ +-- 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 new file mode 100644 index 000000000..4e533b7d8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c38108a.ada @@ -0,0 +1,77 @@ +-- 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 new file mode 100644 index 000000000..120e51a35 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c38108b.ada @@ -0,0 +1,76 @@ +-- 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 new file mode 100644 index 000000000..780436a68 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c38108c0.ada @@ -0,0 +1,36 @@ +-- 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 new file mode 100644 index 000000000..523663fcc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c38108c1.ada @@ -0,0 +1,52 @@ +-- 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 new file mode 100644 index 000000000..9dda7aac0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c38108c2.ada @@ -0,0 +1,47 @@ +-- 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 new file mode 100644 index 000000000..4b24e7c59 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c38108d0.ada @@ -0,0 +1,65 @@ +-- 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 new file mode 100644 index 000000000..895e956a8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c38108d1.ada @@ -0,0 +1,47 @@ +-- 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 new file mode 100644 index 000000000..d0350fc1f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c38202a.ada @@ -0,0 +1,197 @@ +-- 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 new file mode 100644 index 000000000..6d9ddb4a1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3900010.a @@ -0,0 +1,147 @@ +-- 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 new file mode 100644 index 000000000..68207f32a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3900011.am @@ -0,0 +1,253 @@ +-- 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 new file mode 100644 index 000000000..b3d11afed --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c390002.a @@ -0,0 +1,165 @@ +-- 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 new file mode 100644 index 000000000..643aad1cd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c390003.a @@ -0,0 +1,419 @@ +-- 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 new file mode 100644 index 000000000..2c120bab9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c390004.a @@ -0,0 +1,404 @@ +-- 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 new file mode 100644 index 000000000..8a00b2656 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3900050.a @@ -0,0 +1,157 @@ +-- 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 new file mode 100644 index 000000000..d23a62bff --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3900051.a @@ -0,0 +1,137 @@ +-- 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 new file mode 100644 index 000000000..11d26db4a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3900052.a @@ -0,0 +1,138 @@ +-- 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 new file mode 100644 index 000000000..8ea3c118a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3900053.am @@ -0,0 +1,191 @@ +-- 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 new file mode 100644 index 000000000..b77219c57 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3900060.a @@ -0,0 +1,159 @@ +-- 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 new file mode 100644 index 000000000..f776dcdb8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3900061.a @@ -0,0 +1,138 @@ +-- 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 new file mode 100644 index 000000000..87a1cd5a3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3900062.a @@ -0,0 +1,137 @@ +-- 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 new file mode 100644 index 000000000..7d88719ad --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3900063.am @@ -0,0 +1,138 @@ +-- 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 new file mode 100644 index 000000000..46f59f66c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c390007.a @@ -0,0 +1,374 @@ +-- 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 new file mode 100644 index 000000000..1590e5027 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c390010.a @@ -0,0 +1,216 @@ +-- 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 new file mode 100644 index 000000000..74cf0eb04 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c390011.a @@ -0,0 +1,250 @@ +-- 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 new file mode 100644 index 000000000..7e5f43dc0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c39006a.ada @@ -0,0 +1,207 @@ +-- 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 new file mode 100644 index 000000000..f7b4f2757 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c39006b.ada @@ -0,0 +1,163 @@ +-- 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 new file mode 100644 index 000000000..c29dd6f31 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c39006c0.ada @@ -0,0 +1,69 @@ +-- 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 new file mode 100644 index 000000000..0665cf037 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c39006c1.ada @@ -0,0 +1,41 @@ +-- 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 new file mode 100644 index 000000000..f2969e82e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c39006d.ada @@ -0,0 +1,144 @@ +-- 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 new file mode 100644 index 000000000..77e527135 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c39006e.ada @@ -0,0 +1,213 @@ +-- 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 new file mode 100644 index 000000000..58a9b894b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c39006f0.ada @@ -0,0 +1,44 @@ +-- 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 new file mode 100644 index 000000000..b90477db8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c39006f1.ada @@ -0,0 +1,42 @@ +-- 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 new file mode 100644 index 000000000..2559b59aa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c39006f2.ada @@ -0,0 +1,130 @@ +-- 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 new file mode 100644 index 000000000..206a47586 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c39006f3.ada @@ -0,0 +1,49 @@ +-- 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 new file mode 100644 index 000000000..48990a442 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c39006g.ada @@ -0,0 +1,71 @@ +-- 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 new file mode 100644 index 000000000..e25d96ae6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c39007a.ada @@ -0,0 +1,132 @@ +-- 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 new file mode 100644 index 000000000..c95c064d2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c39007b.ada @@ -0,0 +1,83 @@ +-- 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 new file mode 100644 index 000000000..4e40dc391 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c39008a.ada @@ -0,0 +1,73 @@ +-- 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 new file mode 100644 index 000000000..d148e0ccf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c39008b.ada @@ -0,0 +1,77 @@ +-- 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 new file mode 100644 index 000000000..22d482559 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c39008c.ada @@ -0,0 +1,97 @@ +-- 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 new file mode 100644 index 000000000..18016de09 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c390a010.a @@ -0,0 +1,127 @@ +-- 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 new file mode 100644 index 000000000..b5234e913 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c390a011.am @@ -0,0 +1,218 @@ +-- 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 new file mode 100644 index 000000000..29cd3ca97 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c390a020.a @@ -0,0 +1,90 @@ +-- 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 new file mode 100644 index 000000000..5d099f370 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c390a021.a @@ -0,0 +1,133 @@ +-- 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 new file mode 100644 index 000000000..3ba273fe5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c390a022.am @@ -0,0 +1,179 @@ +-- 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 new file mode 100644 index 000000000..51554a49a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c390a030.a @@ -0,0 +1,188 @@ +-- 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 new file mode 100644 index 000000000..7f380c61d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c390a031.am @@ -0,0 +1,167 @@ +-- 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 new file mode 100644 index 000000000..bca752576 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c391001.a @@ -0,0 +1,329 @@ +-- 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 new file mode 100644 index 000000000..77fbfb328 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c391002.a @@ -0,0 +1,493 @@ +-- 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 new file mode 100644 index 000000000..41493c227 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c392002.a @@ -0,0 +1,349 @@ +-- 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 new file mode 100644 index 000000000..d7c5be228 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c392003.a @@ -0,0 +1,453 @@ +-- 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 new file mode 100644 index 000000000..0851db1d2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c392004.a @@ -0,0 +1,189 @@ +-- 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 new file mode 100644 index 000000000..be49cd48b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c392005.a @@ -0,0 +1,367 @@ +-- 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 new file mode 100644 index 000000000..27b4e2a86 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c392008.a @@ -0,0 +1,401 @@ +-- 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 new file mode 100644 index 000000000..ec168780c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c392010.a @@ -0,0 +1,512 @@ +-- 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 new file mode 100644 index 000000000..c32ec77c0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c392011.a @@ -0,0 +1,299 @@ +-- 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 new file mode 100644 index 000000000..3873d9e62 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c392013.a @@ -0,0 +1,179 @@ +-- 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 new file mode 100644 index 000000000..8ecb4144b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c392014.a @@ -0,0 +1,227 @@ +-- 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 new file mode 100644 index 000000000..8ad789142 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c392a01.a @@ -0,0 +1,265 @@ +-- 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 new file mode 100644 index 000000000..6bd3cece7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c392c05.a @@ -0,0 +1,164 @@ +-- 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 new file mode 100644 index 000000000..f13cc0b01 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c392c07.a @@ -0,0 +1,190 @@ +-- 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 new file mode 100644 index 000000000..bb6e19202 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c392d01.a @@ -0,0 +1,324 @@ +-- 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 new file mode 100644 index 000000000..d8e012cbe --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c392d02.a @@ -0,0 +1,185 @@ +-- 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 new file mode 100644 index 000000000..3a488952e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c392d03.a @@ -0,0 +1,248 @@ +-- 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 new file mode 100644 index 000000000..9d6f85c63 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c393001.a @@ -0,0 +1,407 @@ +-- 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 new file mode 100644 index 000000000..93458eeff --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c393007.a @@ -0,0 +1,157 @@ +-- 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 new file mode 100644 index 000000000..d2d2aefed --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c393008.a @@ -0,0 +1,204 @@ +-- 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 new file mode 100644 index 000000000..1353f9c37 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c393009.a @@ -0,0 +1,170 @@ +-- 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 new file mode 100644 index 000000000..6a52cf889 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c393010.a @@ -0,0 +1,306 @@ +-- 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 new file mode 100644 index 000000000..8741e87c1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c393011.a @@ -0,0 +1,220 @@ +-- 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 new file mode 100644 index 000000000..16bf6ddcc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c393012.a @@ -0,0 +1,221 @@ +-- 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 new file mode 100644 index 000000000..177bd34b8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c393a02.a @@ -0,0 +1,213 @@ +-- 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 new file mode 100644 index 000000000..90106f4bf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c393a03.a @@ -0,0 +1,242 @@ +-- 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 new file mode 100644 index 000000000..b404559cc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c393a05.a @@ -0,0 +1,166 @@ +-- 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 new file mode 100644 index 000000000..c257d5fa0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c393a06.a @@ -0,0 +1,201 @@ +-- 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 new file mode 100644 index 000000000..5d1b46daa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c393b12.a @@ -0,0 +1,131 @@ +-- 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 new file mode 100644 index 000000000..c533badbe --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c393b13.a @@ -0,0 +1,105 @@ +-- 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 new file mode 100644 index 000000000..f100377aa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c393b14.a @@ -0,0 +1,147 @@ +-- 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 new file mode 100644 index 000000000..f8a0681e7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a0001.a @@ -0,0 +1,138 @@ +-- 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 new file mode 100644 index 000000000..5c05d43fb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a0002.a @@ -0,0 +1,142 @@ +-- 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 new file mode 100644 index 000000000..4f9fdbe29 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a0003.a @@ -0,0 +1,144 @@ +-- 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 new file mode 100644 index 000000000..2557546c2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a0004.a @@ -0,0 +1,115 @@ +-- 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 new file mode 100644 index 000000000..1f2368957 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a0005.a @@ -0,0 +1,147 @@ +-- 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 new file mode 100644 index 000000000..effab3465 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a0006.a @@ -0,0 +1,163 @@ +-- 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 new file mode 100644 index 000000000..ff18d2f9e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a0007.a @@ -0,0 +1,234 @@ +-- 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 new file mode 100644 index 000000000..6cd9ce3dd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a0008.a @@ -0,0 +1,150 @@ +-- 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 new file mode 100644 index 000000000..ba3f2f6e1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a0009.a @@ -0,0 +1,219 @@ +-- 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 new file mode 100644 index 000000000..5628c9518 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a0010.a @@ -0,0 +1,158 @@ +-- 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 new file mode 100644 index 000000000..985080659 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a0011.a @@ -0,0 +1,186 @@ +-- 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 new file mode 100644 index 000000000..5ce7b6175 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a00120.a @@ -0,0 +1,83 @@ +-- 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 new file mode 100644 index 000000000..acb1dab99 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a00121.a @@ -0,0 +1,76 @@ +-- 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 new file mode 100644 index 000000000..7af03c256 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a00122.am @@ -0,0 +1,113 @@ +-- 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 new file mode 100644 index 000000000..b23d4ee11 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a0013.a @@ -0,0 +1,347 @@ +-- 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 new file mode 100644 index 000000000..c83ab4f5e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a0014.a @@ -0,0 +1,453 @@ +-- 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 new file mode 100644 index 000000000..856c910f9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a0015.a @@ -0,0 +1,267 @@ +-- 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 new file mode 100644 index 000000000..9b05b5da2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a1001.a @@ -0,0 +1,315 @@ +-- 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 new file mode 100644 index 000000000..27d1f843c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a1002.a @@ -0,0 +1,251 @@ +-- 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 new file mode 100644 index 000000000..c3c7f4410 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a2001.a @@ -0,0 +1,460 @@ +-- 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 new file mode 100644 index 000000000..63ea7008b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a2002.a @@ -0,0 +1,295 @@ +-- 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 new file mode 100644 index 000000000..deb92f1a8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a2003.a @@ -0,0 +1,329 @@ +-- 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 new file mode 100644 index 000000000..8271d4869 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a @@ -0,0 +1,367 @@ +-- 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 new file mode 100644 index 000000000..23b2c1c5d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c3a2a02.a @@ -0,0 +1,396 @@ +-- 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 new file mode 100644 index 000000000..26555531b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c410001.a @@ -0,0 +1,303 @@ +-- 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 new file mode 100644 index 000000000..c826a227b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41101d.ada @@ -0,0 +1,102 @@ +-- 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 new file mode 100644 index 000000000..21feafb36 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41103a.ada @@ -0,0 +1,239 @@ +-- 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 new file mode 100644 index 000000000..7fbab7174 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41103b.ada @@ -0,0 +1,366 @@ +-- 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 new file mode 100644 index 000000000..540702869 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41104a.ada @@ -0,0 +1,240 @@ +-- 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 new file mode 100644 index 000000000..1b5ad40f6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41105a.ada @@ -0,0 +1,104 @@ +-- 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 new file mode 100644 index 000000000..13781fbf4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41107a.ada @@ -0,0 +1,142 @@ +-- 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 new file mode 100644 index 000000000..a589ba765 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41201d.ada @@ -0,0 +1,105 @@ +-- 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 new file mode 100644 index 000000000..7e751650f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41203a.ada @@ -0,0 +1,241 @@ +-- 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 new file mode 100644 index 000000000..2bfb0952e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41203b.ada @@ -0,0 +1,378 @@ +-- 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 new file mode 100644 index 000000000..0ad8439b3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41204a.ada @@ -0,0 +1,86 @@ +-- 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 new file mode 100644 index 000000000..220ae33cc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41205a.ada @@ -0,0 +1,94 @@ +-- 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 new file mode 100644 index 000000000..b12e43d19 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41206a.ada @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..6f1807f4a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41207a.ada @@ -0,0 +1,69 @@ +-- 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 new file mode 100644 index 000000000..78017f5dc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41301a.ada @@ -0,0 +1,216 @@ +-- 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 new file mode 100644 index 000000000..4224effd7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303a.ada @@ -0,0 +1,120 @@ +-- 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 new file mode 100644 index 000000000..cb6c1ab6b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303b.ada @@ -0,0 +1,117 @@ +-- 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 new file mode 100644 index 000000000..d68872539 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303c.ada @@ -0,0 +1,116 @@ +-- 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 new file mode 100644 index 000000000..f49dae27c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303e.ada @@ -0,0 +1,124 @@ +-- 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 new file mode 100644 index 000000000..aa474cd8d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303f.ada @@ -0,0 +1,117 @@ +-- 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 new file mode 100644 index 000000000..39a6aa3f7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303g.ada @@ -0,0 +1,121 @@ +-- 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 new file mode 100644 index 000000000..1c0aff25a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303i.ada @@ -0,0 +1,127 @@ +-- 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 new file mode 100644 index 000000000..fad2a394e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303j.ada @@ -0,0 +1,122 @@ +-- 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 new file mode 100644 index 000000000..bb6f2a785 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303k.ada @@ -0,0 +1,124 @@ +-- 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 new file mode 100644 index 000000000..f0c13d3eb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303m.ada @@ -0,0 +1,150 @@ +-- 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 new file mode 100644 index 000000000..431d01e6d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303n.ada @@ -0,0 +1,147 @@ +-- 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 new file mode 100644 index 000000000..8f488bde6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303o.ada @@ -0,0 +1,145 @@ +-- 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 new file mode 100644 index 000000000..bf8756240 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303q.ada @@ -0,0 +1,152 @@ +-- 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 new file mode 100644 index 000000000..b219e3c74 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303r.ada @@ -0,0 +1,145 @@ +-- 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 new file mode 100644 index 000000000..09ce2f49e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303s.ada @@ -0,0 +1,151 @@ +-- 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 new file mode 100644 index 000000000..92a76014e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303u.ada @@ -0,0 +1,158 @@ +-- 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 new file mode 100644 index 000000000..e6a6259af --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303v.ada @@ -0,0 +1,155 @@ +-- 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 new file mode 100644 index 000000000..a1bf58050 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41303w.ada @@ -0,0 +1,159 @@ +-- 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 new file mode 100644 index 000000000..124d527c5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41304a.ada @@ -0,0 +1,119 @@ +-- 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 new file mode 100644 index 000000000..c6dec9c6c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41304b.ada @@ -0,0 +1,198 @@ +-- 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 new file mode 100644 index 000000000..2521d7bd4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41306a.ada @@ -0,0 +1,104 @@ +-- 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 new file mode 100644 index 000000000..390f978a0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41306b.ada @@ -0,0 +1,217 @@ +-- 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 new file mode 100644 index 000000000..dc715c881 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41306c.ada @@ -0,0 +1,215 @@ +-- 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 new file mode 100644 index 000000000..e65e79fb8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41307d.ada @@ -0,0 +1,255 @@ +-- 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('+'); + <> + 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 new file mode 100644 index 000000000..a1dc91734 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41309a.ada @@ -0,0 +1,69 @@ +-- 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 new file mode 100644 index 000000000..011174a62 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41320a.ada @@ -0,0 +1,97 @@ +-- 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 new file mode 100644 index 000000000..8064c127b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41321a.ada @@ -0,0 +1,106 @@ +-- 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 new file mode 100644 index 000000000..eaf3a6ff7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41322a.ada @@ -0,0 +1,125 @@ +-- 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 new file mode 100644 index 000000000..f82a97abf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41323a.ada @@ -0,0 +1,125 @@ +-- 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 new file mode 100644 index 000000000..19992a29b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41324a.ada @@ -0,0 +1,120 @@ +-- 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 new file mode 100644 index 000000000..95437ab3e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41325a.ada @@ -0,0 +1,173 @@ +-- 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 new file mode 100644 index 000000000..9ef3c65b0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41326a.ada @@ -0,0 +1,72 @@ +-- 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 new file mode 100644 index 000000000..4d5d85284 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41327a.ada @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..3c6ea5b2f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41328a.ada @@ -0,0 +1,100 @@ +-- 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 new file mode 100644 index 000000000..f58a8a472 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41401a.ada @@ -0,0 +1,216 @@ +-- 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 new file mode 100644 index 000000000..003fb12eb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41402a.ada @@ -0,0 +1,118 @@ +-- 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 new file mode 100644 index 000000000..9aa937852 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c41404a.ada @@ -0,0 +1,136 @@ +-- 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 new file mode 100644 index 000000000..ae4b4d8fd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c420001.a @@ -0,0 +1,110 @@ +-- 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 new file mode 100644 index 000000000..6c2201704 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c42006a.ada @@ -0,0 +1,99 @@ +-- 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 new file mode 100644 index 000000000..09fd6e6ef --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c42007e.ada @@ -0,0 +1,117 @@ +-- 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 new file mode 100644 index 000000000..976788118 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43003a.ada @@ -0,0 +1,64 @@ +-- 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 new file mode 100644 index 000000000..86e705de7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43004a.ada @@ -0,0 +1,350 @@ +-- 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 new file mode 100644 index 000000000..253467477 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43004c.ada @@ -0,0 +1,230 @@ +-- 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 new file mode 100644 index 000000000..7d417ce69 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c431001.a @@ -0,0 +1,464 @@ +-- 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 new file mode 100644 index 000000000..4267f5895 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43103a.ada @@ -0,0 +1,127 @@ +-- 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 new file mode 100644 index 000000000..994e42459 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43103b.ada @@ -0,0 +1,186 @@ +-- 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 new file mode 100644 index 000000000..3c1ee9dda --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43104a.ada @@ -0,0 +1,86 @@ +-- 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 new file mode 100644 index 000000000..28e9d280d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43105a.ada @@ -0,0 +1,97 @@ +-- 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 new file mode 100644 index 000000000..6a7ea8171 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43105b.ada @@ -0,0 +1,94 @@ +-- 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 new file mode 100644 index 000000000..64ac9503c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43106a.ada @@ -0,0 +1,90 @@ +-- 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 new file mode 100644 index 000000000..5fcc1a273 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43107a.ada @@ -0,0 +1,125 @@ +-- 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 new file mode 100644 index 000000000..24c140f67 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43108a.ada @@ -0,0 +1,111 @@ +-- 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 new file mode 100644 index 000000000..dab75b388 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c432001.a @@ -0,0 +1,512 @@ +-- 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 new file mode 100644 index 000000000..5de821b30 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c432002.a @@ -0,0 +1,764 @@ +-- 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 new file mode 100644 index 000000000..8988992c4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c432003.a @@ -0,0 +1,594 @@ +-- 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 new file mode 100644 index 000000000..3a1486211 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c432004.a @@ -0,0 +1,319 @@ +-- 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 new file mode 100644 index 000000000..33450dba0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43204a.ada @@ -0,0 +1,158 @@ +-- 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 new file mode 100644 index 000000000..1db9f7f17 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43204c.ada @@ -0,0 +1,192 @@ +-- 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 new file mode 100644 index 000000000..8b6566660 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43204e.ada @@ -0,0 +1,179 @@ +-- 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 new file mode 100644 index 000000000..bd6cc6170 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43204f.ada @@ -0,0 +1,107 @@ +-- 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 new file mode 100644 index 000000000..3474e5728 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43204g.ada @@ -0,0 +1,125 @@ +-- 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 new file mode 100644 index 000000000..54b19587b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43204h.ada @@ -0,0 +1,107 @@ +-- 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 new file mode 100644 index 000000000..1a761a541 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43204i.ada @@ -0,0 +1,106 @@ +-- 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 new file mode 100644 index 000000000..9946ba9ee --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43205a.ada @@ -0,0 +1,111 @@ +-- 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 new file mode 100644 index 000000000..7f4dfd6fd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43205b.ada @@ -0,0 +1,82 @@ +-- 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 new file mode 100644 index 000000000..e78837027 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43205c.ada @@ -0,0 +1,83 @@ +-- 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 new file mode 100644 index 000000000..ddffcbe8a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43205d.ada @@ -0,0 +1,73 @@ +-- 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 new file mode 100644 index 000000000..d06f209ae --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43205e.ada @@ -0,0 +1,117 @@ +-- 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 new file mode 100644 index 000000000..54e0b743a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43205g.ada @@ -0,0 +1,105 @@ +-- 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 new file mode 100644 index 000000000..9e4dc4ae0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43205h.ada @@ -0,0 +1,82 @@ +-- 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 new file mode 100644 index 000000000..44c255766 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43205i.ada @@ -0,0 +1,83 @@ +-- 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 new file mode 100644 index 000000000..946e074dd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43205j.ada @@ -0,0 +1,146 @@ +-- 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 new file mode 100644 index 000000000..a3a712a44 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43205k.ada @@ -0,0 +1,110 @@ +-- 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 new file mode 100644 index 000000000..af738920e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43206a.ada @@ -0,0 +1,242 @@ +-- 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 new file mode 100644 index 000000000..197a9155e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43207b.ada @@ -0,0 +1,149 @@ +-- 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 new file mode 100644 index 000000000..5733ec8fa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43207d.ada @@ -0,0 +1,135 @@ +-- 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 new file mode 100644 index 000000000..c04a395ea --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43208a.ada @@ -0,0 +1,208 @@ +-- 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 new file mode 100644 index 000000000..de5ac5fd1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43208b.ada @@ -0,0 +1,266 @@ +-- 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 new file mode 100644 index 000000000..c86d9494c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43209a.ada @@ -0,0 +1,135 @@ +-- 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 new file mode 100644 index 000000000..549021e60 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43210a.ada @@ -0,0 +1,142 @@ +-- 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 new file mode 100644 index 000000000..cf745d0dc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43211a.ada @@ -0,0 +1,170 @@ +-- 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 new file mode 100644 index 000000000..fd940332e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43212a.ada @@ -0,0 +1,154 @@ +-- 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 new file mode 100644 index 000000000..30764670e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43212c.ada @@ -0,0 +1,102 @@ +-- 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 new file mode 100644 index 000000000..6d953c4d7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43214a.ada @@ -0,0 +1,100 @@ +-- 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 new file mode 100644 index 000000000..6db7e2b9d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43214b.ada @@ -0,0 +1,105 @@ +-- 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 new file mode 100644 index 000000000..b5233022f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43214c.ada @@ -0,0 +1,75 @@ +-- 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 new file mode 100644 index 000000000..7274a4b46 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43214d.ada @@ -0,0 +1,77 @@ +-- 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 new file mode 100644 index 000000000..88ebb510b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43214e.ada @@ -0,0 +1,147 @@ +-- 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 new file mode 100644 index 000000000..2c19d1748 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43214f.ada @@ -0,0 +1,151 @@ +-- 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 new file mode 100644 index 000000000..ff832cc2a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43215a.ada @@ -0,0 +1,138 @@ +-- 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 new file mode 100644 index 000000000..a80f818f2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43215b.ada @@ -0,0 +1,142 @@ +-- 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 new file mode 100644 index 000000000..f1056576f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43222a.ada @@ -0,0 +1,49 @@ +-- 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 new file mode 100644 index 000000000..799309a82 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c43224a.ada @@ -0,0 +1,75 @@ +-- 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 new file mode 100644 index 000000000..613b688c8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c433001.a @@ -0,0 +1,302 @@ +-- 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. + +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 ("First Component incorrect (" & Test_Case & ")"); + end if; + if Obj(High) /= Last_Component then + Report.Failed ("First 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 ("First Component incorrect (" & Test_Case & ")"); + end if; + if Obj(High) /= Last_Component then + Report.Failed ("First 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 new file mode 100644 index 000000000..57ad7c4d0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c44003d.ada @@ -0,0 +1,188 @@ +-- 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 new file mode 100644 index 000000000..11121b20c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c44003f.ada @@ -0,0 +1,143 @@ +-- 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 new file mode 100644 index 000000000..6825cc218 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c44003g.ada @@ -0,0 +1,134 @@ +-- 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 new file mode 100644 index 000000000..e398ffc63 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c450001.a @@ -0,0 +1,434 @@ +-- 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 new file mode 100644 index 000000000..f18b1be57 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45112a.ada @@ -0,0 +1,233 @@ +-- 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 new file mode 100644 index 000000000..ef6a7c0a9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45112b.ada @@ -0,0 +1,234 @@ +-- 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 new file mode 100644 index 000000000..14471d348 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45113a.ada @@ -0,0 +1,91 @@ +-- 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 new file mode 100644 index 000000000..d49b9eda5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45114b.ada @@ -0,0 +1,73 @@ +-- 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 new file mode 100644 index 000000000..ec78cd2a5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c452001.a @@ -0,0 +1,707 @@ +-- 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 new file mode 100644 index 000000000..5c1970d34 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45201a.ada @@ -0,0 +1,242 @@ +-- 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 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 new file mode 100644 index 000000000..7c64c8bf4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45201b.ada @@ -0,0 +1,236 @@ +-- 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 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 new file mode 100644 index 000000000..bf2a02fef --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45202b.ada @@ -0,0 +1,95 @@ +-- 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 new file mode 100644 index 000000000..e7461aa8d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45210a.ada @@ -0,0 +1,191 @@ +-- 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 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 new file mode 100644 index 000000000..8d73d771e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45211a.ada @@ -0,0 +1,66 @@ +-- 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 new file mode 100644 index 000000000..382ccbb6d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45220a.ada @@ -0,0 +1,129 @@ +-- 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 new file mode 100644 index 000000000..87ba73442 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45220b.ada @@ -0,0 +1,191 @@ +-- 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 new file mode 100644 index 000000000..cb505f256 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45220c.ada @@ -0,0 +1,138 @@ +-- 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 new file mode 100644 index 000000000..752d1fcaa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45220d.ada @@ -0,0 +1,200 @@ +-- 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 new file mode 100644 index 000000000..0fbf5bfeb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45220e.ada @@ -0,0 +1,74 @@ +-- 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 new file mode 100644 index 000000000..3d557d95b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45220f.ada @@ -0,0 +1,67 @@ +-- 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 new file mode 100644 index 000000000..d5fce67cd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45231a.ada @@ -0,0 +1,252 @@ +-- 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 new file mode 100644 index 000000000..ba5fecf40 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45231b.dep @@ -0,0 +1,265 @@ +-- 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 new file mode 100644 index 000000000..d2971e295 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45231c.dep @@ -0,0 +1,265 @@ +-- 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 new file mode 100644 index 000000000..66be11b1b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45231d.tst @@ -0,0 +1,274 @@ +-- 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 new file mode 100644 index 000000000..459bc835b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45232b.ada @@ -0,0 +1,135 @@ +-- 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 new file mode 100644 index 000000000..bd05afc3b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45242b.ada @@ -0,0 +1,148 @@ +-- 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 new file mode 100644 index 000000000..0e1bbb508 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45251a.ada @@ -0,0 +1,178 @@ +-- 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 new file mode 100644 index 000000000..e21496662 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45252a.ada @@ -0,0 +1,200 @@ +-- 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 new file mode 100644 index 000000000..bc6b46d38 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45252b.ada @@ -0,0 +1,146 @@ +-- 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 new file mode 100644 index 000000000..d2a06618a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45253a.ada @@ -0,0 +1,97 @@ +-- 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 new file mode 100644 index 000000000..270dc88dc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45262a.ada @@ -0,0 +1,214 @@ +-- 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 new file mode 100644 index 000000000..9d4e80676 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45262b.ada @@ -0,0 +1,219 @@ +-- 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 new file mode 100644 index 000000000..a4e156a74 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45262c.ada @@ -0,0 +1,216 @@ +-- 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 new file mode 100644 index 000000000..7889501b5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45262d.ada @@ -0,0 +1,105 @@ +-- 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 new file mode 100644 index 000000000..d701be0f6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45264a.ada @@ -0,0 +1,109 @@ +-- 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 new file mode 100644 index 000000000..44063f7ac --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45264b.ada @@ -0,0 +1,88 @@ +-- 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 new file mode 100644 index 000000000..c9959a5ba --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45264c.ada @@ -0,0 +1,153 @@ +-- 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 new file mode 100644 index 000000000..711124358 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45265a.ada @@ -0,0 +1,196 @@ +-- 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 new file mode 100644 index 000000000..8e621993b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45271a.ada @@ -0,0 +1,112 @@ +-- 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 new file mode 100644 index 000000000..447d468df --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45272a.ada @@ -0,0 +1,105 @@ +-- 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 new file mode 100644 index 000000000..ae74c2957 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45273a.ada @@ -0,0 +1,133 @@ +-- 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 new file mode 100644 index 000000000..ea7473192 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45274a.ada @@ -0,0 +1,222 @@ +-- 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 new file mode 100644 index 000000000..4833b6d7d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45274b.ada @@ -0,0 +1,229 @@ +-- 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 new file mode 100644 index 000000000..647089782 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45274c.ada @@ -0,0 +1,187 @@ +-- 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 new file mode 100644 index 000000000..24353f1ce --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45281a.ada @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..e248e3ae2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45282a.ada @@ -0,0 +1,170 @@ +-- 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 new file mode 100644 index 000000000..af3a2bf2d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45282b.ada @@ -0,0 +1,347 @@ +-- 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 new file mode 100644 index 000000000..86c9eb2d8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45291a.ada @@ -0,0 +1,158 @@ +-- 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/c45303a.ada b/gcc/testsuite/ada/acats/tests/c4/c45303a.ada new file mode 100644 index 000000000..01cd53dba --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45303a.ada @@ -0,0 +1,80 @@ +-- 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 new file mode 100644 index 000000000..8a5dfe991 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45304a.ada @@ -0,0 +1,82 @@ +-- 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 new file mode 100644 index 000000000..23620f8b9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45304b.dep @@ -0,0 +1,111 @@ +-- 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 new file mode 100644 index 000000000..9eaba634f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45304c.dep @@ -0,0 +1,110 @@ +-- 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 new file mode 100644 index 000000000..8857c32f2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45322a.ada @@ -0,0 +1,196 @@ +-- 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 new file mode 100644 index 000000000..98c17d740 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45323a.ada @@ -0,0 +1,67 @@ +-- 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 new file mode 100644 index 000000000..bdbcd6150 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45331a.ada @@ -0,0 +1,357 @@ +-- 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 new file mode 100644 index 000000000..73a05290a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45342a.ada @@ -0,0 +1,99 @@ +-- 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 new file mode 100644 index 000000000..a99db7f28 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45343a.ada @@ -0,0 +1,75 @@ +-- 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 new file mode 100644 index 000000000..b75f2a7ef --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45344a.ada @@ -0,0 +1,116 @@ +-- 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 new file mode 100644 index 000000000..e4b31ec59 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45345b.ada @@ -0,0 +1,118 @@ +-- 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 new file mode 100644 index 000000000..a93ae875e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45347a.ada @@ -0,0 +1,96 @@ +-- 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 new file mode 100644 index 000000000..220100b39 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45347b.ada @@ -0,0 +1,90 @@ +-- 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 new file mode 100644 index 000000000..0ad23a7a6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45347c.ada @@ -0,0 +1,108 @@ +-- 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 new file mode 100644 index 000000000..0791be10f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45347d.ada @@ -0,0 +1,93 @@ +-- 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 new file mode 100644 index 000000000..0ac3b10a8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45411a.ada @@ -0,0 +1,120 @@ +-- 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 new file mode 100644 index 000000000..faae4b1f7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45411b.dep @@ -0,0 +1,123 @@ +-- 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 new file mode 100644 index 000000000..eaa472362 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45411c.dep @@ -0,0 +1,123 @@ +-- 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 new file mode 100644 index 000000000..23adcbdc6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45411d.ada @@ -0,0 +1,98 @@ +-- 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 new file mode 100644 index 000000000..46833238f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45413a.ada @@ -0,0 +1,74 @@ +-- 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 new file mode 100644 index 000000000..d66e890fc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45431a.ada @@ -0,0 +1,212 @@ +-- 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 new file mode 100644 index 000000000..8685e1b33 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c455001.a @@ -0,0 +1,164 @@ +-- 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 new file mode 100644 index 000000000..a8bd24ce1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45502b.dep @@ -0,0 +1,291 @@ +-- 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 new file mode 100644 index 000000000..96d0212d8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45502c.dep @@ -0,0 +1,295 @@ +-- 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 new file mode 100644 index 000000000..0461b0151 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45503a.ada @@ -0,0 +1,310 @@ +-- 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 new file mode 100644 index 000000000..570c52934 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45503b.dep @@ -0,0 +1,327 @@ +-- 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 new file mode 100644 index 000000000..9a66c3529 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45503c.dep @@ -0,0 +1,331 @@ +-- 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 new file mode 100644 index 000000000..7cc4af4bc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45504a.ada @@ -0,0 +1,92 @@ +-- 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 new file mode 100644 index 000000000..230750540 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45504b.dep @@ -0,0 +1,117 @@ +-- 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 new file mode 100644 index 000000000..d39ee6378 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45504c.dep @@ -0,0 +1,119 @@ +-- 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 new file mode 100644 index 000000000..0b37b13c0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45504d.ada @@ -0,0 +1,214 @@ +-- 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 new file mode 100644 index 000000000..8ad4e59e3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45504e.dep @@ -0,0 +1,234 @@ +-- 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 new file mode 100644 index 000000000..81ea6c194 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45504f.dep @@ -0,0 +1,234 @@ +-- 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 new file mode 100644 index 000000000..747d34b54 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45505a.ada @@ -0,0 +1,65 @@ +-- 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 new file mode 100644 index 000000000..ff78eaba7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45523a.ada @@ -0,0 +1,111 @@ +-- 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 new file mode 100644 index 000000000..6a77909da --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531a.ada @@ -0,0 +1,182 @@ +-- 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 new file mode 100644 index 000000000..74ac115e1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531b.ada @@ -0,0 +1,153 @@ +-- 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 new file mode 100644 index 000000000..a864decdb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531c.ada @@ -0,0 +1,183 @@ +-- 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 new file mode 100644 index 000000000..2c2eb87d1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531d.ada @@ -0,0 +1,153 @@ +-- 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 new file mode 100644 index 000000000..f05ef92c7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531e.ada @@ -0,0 +1,182 @@ +-- 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 new file mode 100644 index 000000000..65b1f1803 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531f.ada @@ -0,0 +1,153 @@ +-- 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 new file mode 100644 index 000000000..b6146ab64 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531g.ada @@ -0,0 +1,183 @@ +-- 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 new file mode 100644 index 000000000..e1351582f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531h.ada @@ -0,0 +1,153 @@ +-- 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 new file mode 100644 index 000000000..ff4765871 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531i.ada @@ -0,0 +1,182 @@ +-- 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 new file mode 100644 index 000000000..7279dd946 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531j.ada @@ -0,0 +1,153 @@ +-- 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 new file mode 100644 index 000000000..2e70d17e5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531k.ada @@ -0,0 +1,184 @@ +-- 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 new file mode 100644 index 000000000..97a6f8d97 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531l.ada @@ -0,0 +1,154 @@ +-- 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 new file mode 100644 index 000000000..25ded1fb6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531m.dep @@ -0,0 +1,189 @@ +-- 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 new file mode 100644 index 000000000..f461ba083 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531n.dep @@ -0,0 +1,160 @@ +-- 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 new file mode 100644 index 000000000..ae8c3953f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531o.dep @@ -0,0 +1,189 @@ +-- 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 new file mode 100644 index 000000000..e4b6ce967 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45531p.dep @@ -0,0 +1,159 @@ +-- 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 new file mode 100644 index 000000000..8ebbc0a37 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532a.ada @@ -0,0 +1,152 @@ +-- 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 new file mode 100644 index 000000000..5077477f3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532b.ada @@ -0,0 +1,159 @@ +-- 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 new file mode 100644 index 000000000..9e9aaa292 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532c.ada @@ -0,0 +1,156 @@ +-- 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 new file mode 100644 index 000000000..51923df95 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532d.ada @@ -0,0 +1,150 @@ +-- 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 new file mode 100644 index 000000000..42989f162 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532e.ada @@ -0,0 +1,151 @@ +-- 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 new file mode 100644 index 000000000..59a9e25bb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532f.ada @@ -0,0 +1,158 @@ +-- 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 new file mode 100644 index 000000000..c9d8f004d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532g.ada @@ -0,0 +1,155 @@ +-- 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 new file mode 100644 index 000000000..ea1d9613f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532h.ada @@ -0,0 +1,149 @@ +-- 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 new file mode 100644 index 000000000..60a7dfe18 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532i.ada @@ -0,0 +1,152 @@ +-- 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 new file mode 100644 index 000000000..a50906c46 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532j.ada @@ -0,0 +1,158 @@ +-- 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 new file mode 100644 index 000000000..1f2bd7102 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532k.ada @@ -0,0 +1,156 @@ +-- 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 new file mode 100644 index 000000000..2ea7fea82 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532l.ada @@ -0,0 +1,150 @@ +-- 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 new file mode 100644 index 000000000..b4001af93 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532m.dep @@ -0,0 +1,157 @@ +-- 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 new file mode 100644 index 000000000..9315c6826 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532n.dep @@ -0,0 +1,163 @@ +-- 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 new file mode 100644 index 000000000..b0126df4b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532o.dep @@ -0,0 +1,161 @@ +-- 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 new file mode 100644 index 000000000..cab503166 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45532p.dep @@ -0,0 +1,155 @@ +-- 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 new file mode 100644 index 000000000..6c087c3fa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45534b.ada @@ -0,0 +1,105 @@ +-- 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 new file mode 100644 index 000000000..760d43011 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45536a.dep @@ -0,0 +1,158 @@ +-- 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 new file mode 100644 index 000000000..9062f93fc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c456001.a @@ -0,0 +1,91 @@ +-- 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 new file mode 100644 index 000000000..3f7a690fb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45611a.ada @@ -0,0 +1,123 @@ +-- 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 new file mode 100644 index 000000000..fb63ef82e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45611b.dep @@ -0,0 +1,141 @@ +-- 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 new file mode 100644 index 000000000..0687d3a48 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45611c.dep @@ -0,0 +1,141 @@ +-- 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 new file mode 100644 index 000000000..b539018bc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45613a.ada @@ -0,0 +1,79 @@ +-- 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 new file mode 100644 index 000000000..4ce07cd9d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45613b.dep @@ -0,0 +1,97 @@ +-- 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 new file mode 100644 index 000000000..074d2b352 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45613c.dep @@ -0,0 +1,97 @@ +-- 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 new file mode 100644 index 000000000..9a0d835bd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45614a.ada @@ -0,0 +1,99 @@ +-- 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 new file mode 100644 index 000000000..c96ab3330 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45614b.dep @@ -0,0 +1,128 @@ +-- 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 new file mode 100644 index 000000000..0a60a13b5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45614c.dep @@ -0,0 +1,125 @@ +-- 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/c45622a.ada b/gcc/testsuite/ada/acats/tests/c4/c45622a.ada new file mode 100644 index 000000000..42f02045f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45622a.ada @@ -0,0 +1,83 @@ +-- C45622A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- 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 EXPONENTIATION OF FLOATING POINT TYPES, CHECK THAT +-- CONSTRAINT_ERROR IS RAISED IF +-- MACHINE_OVERFLOWS IS TRUE AND THE RESULT IS OUTSIDE THE RANGE OF +-- THE BASE TYPE. 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 + +WITH REPORT; USE REPORT; + +PROCEDURE C45622A IS + + TYPE FLT IS DIGITS 5; + + F : FLT; + + FUNCTION EQUAL_FLT (ONE, TWO : FLT) RETURN BOOLEAN IS + BEGIN + RETURN ONE = TWO * FLT (IDENT_INT(1)); + END EQUAL_FLT; + +BEGIN + TEST ("C45622A", "FOR EXPONENTIATION OF FLOATING POINT TYPES, " & + "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED IF MACHINE_OVERFLOWS IS TRUE AND " & + "THE RESULT IS OUTSIDE THE RANGE OF THE BASE " & + "TYPE. THIS TESTS DIGITS 5"); + + IF FLT'MACHINE_OVERFLOWS THEN + BEGIN + F := (FLT'BASE'LAST)**IDENT_INT (2); + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED FOR " & + "EXPONENTIATION"); + + IF NOT EQUAL_FLT(F,F) THEN + COMMENT ("DON'T OPTIMIZE F"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR WAS RAISED FOR " & + "EXPONENTIATION"); + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED FOR EXPONENTIATION"); + END; + ELSE + NOT_APPLICABLE ("THIS TEST IS NOT APPLICABLE DUE TO " & + "MACHINE_OVERFLOWS BEING FALSE"); + END IF; + + RESULT; +END C45622A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45624a.ada b/gcc/testsuite/ada/acats/tests/c4/c45624a.ada new file mode 100644 index 000000000..32ba4c07a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45624a.ada @@ -0,0 +1,86 @@ +-- C45624A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- 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, CHECK THAT CONSTRAINT_ERROR +-- IS RAISED IF THE RESULT OF A FLOATING POINT +-- EXPONENTIATION IS OUTSIDE THE RANGE OF THE BASE TYPE AND +-- MACHINE_OVERFLOWS IS FALSE. 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 + +WITH REPORT; USE REPORT; + +PROCEDURE C45624A IS + + TYPE FLT IS DIGITS 5; + + F : FLT; + + FUNCTION EQUAL_FLT (ONE, TWO : FLT) RETURN BOOLEAN IS + BEGIN + IF EQUAL(3,3) THEN + RETURN ONE = TWO; + ELSE + RETURN ONE /= TWO; + END IF; + END EQUAL_FLT; + +BEGIN + TEST ("C45624A", "FOR FLOATING POINT TYPES, CHECK THAT " & + "CONSTRAINT_ERROR IS RAISED " & + "IF MACHINE_OVERFLOWS IS FALSE. THIS TESTS " & + "DIGITS 5"); + + IF FLT'MACHINE_OVERFLOWS THEN + NOT_APPLICABLE ("THIS TEST IS NOT APPLICABLE DUE TO " & + "MACHINE_OVERFLOWS BEING TRUE"); + ELSE + BEGIN + F := FLT'BASE'FIRST**IDENT_INT (2); + COMMENT ("CONSTRAINT_ERROR WAS NOT RAISED WHEN " & + "MACHINE_OVERFLOWS WAS FALSE"); + + 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 WHEN " & + "MACHINE_OVERFLOWS WAS FALSE"); + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED"); + END; + END IF; + + RESULT; +END C45624A; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45624b.ada b/gcc/testsuite/ada/acats/tests/c4/c45624b.ada new file mode 100644 index 000000000..c7bd592d6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45624b.ada @@ -0,0 +1,81 @@ +-- C45624B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- 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, CHECK THAT +-- CONSTRAINT_ERROR IS RAISED IF THE RESULT OF A FLOATING POINT +-- EXPONENTIATION IS OUTSIDE THE RANGE OF THE BASE TYPE AND +-- MACHINE_OVERFLOWS IS FALSE. THIS TESTS DIGITS 6. + +-- *** 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 COMPATIBILITY + +WITH REPORT; USE REPORT; + +PROCEDURE C45624B IS + + TYPE FLT IS DIGITS 6; + + F : FLT; + + FUNCTION EQUAL_FLT (ONE, TWO : FLT) RETURN BOOLEAN IS + BEGIN + RETURN ONE = TWO * FLT (IDENT_INT(1)); + END EQUAL_FLT; + +BEGIN + TEST ("C45624B", "FOR FLOATING POINT TYPES, CHECK THAT " & + "CONSTRAINT_ERROR IS RAISED " & + "IF MACHINE_OVERFLOWS IS FALSE. THIS TESTS " & + "DIGITS 6"); + + IF FLT'MACHINE_OVERFLOWS THEN + NOT_APPLICABLE ("THIS TEST IS NOT APPLICABLE DUE TO " & + "MACHINE_OVERFLOWS BEING TRUE"); + ELSE + BEGIN + F := FLT'BASE'LAST**IDENT_INT (2); + COMMENT ("CONSTRAINT_ERROR WAS NOT RAISED WHEN " & + "MACHINE_OVERFLOWS WAS FALSE"); + IF NOT EQUAL_FLT(F,F**IDENT_INT(1)) THEN + COMMENT ("DON'T OPTIMIZE F"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR WAS RAISED WHEN " & + "MACHINE_OVERFLOWS WAS FALSE"); + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED"); + END; + END IF; + + RESULT; +END C45624B; diff --git a/gcc/testsuite/ada/acats/tests/c4/c45631a.ada b/gcc/testsuite/ada/acats/tests/c4/c45631a.ada new file mode 100644 index 000000000..43f794abc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45631a.ada @@ -0,0 +1,98 @@ +-- 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 new file mode 100644 index 000000000..750ea210d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45631b.dep @@ -0,0 +1,116 @@ +-- 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 new file mode 100644 index 000000000..2d47637ab --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45631c.dep @@ -0,0 +1,122 @@ +-- 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 new file mode 100644 index 000000000..399188eb0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45632a.ada @@ -0,0 +1,76 @@ +-- 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 new file mode 100644 index 000000000..fdf33713a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45632b.dep @@ -0,0 +1,94 @@ +-- 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 new file mode 100644 index 000000000..72564bf5b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45632c.dep @@ -0,0 +1,94 @@ +-- 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 new file mode 100644 index 000000000..c568b843b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45651a.ada @@ -0,0 +1,246 @@ +-- 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 new file mode 100644 index 000000000..bf23598e3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45662a.ada @@ -0,0 +1,105 @@ +-- 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 new file mode 100644 index 000000000..7feb6a655 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45662b.ada @@ -0,0 +1,120 @@ +-- 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 new file mode 100644 index 000000000..1e5405525 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c45672a.ada @@ -0,0 +1,109 @@ +-- 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 new file mode 100644 index 000000000..907b8564f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460001.a @@ -0,0 +1,300 @@ +-- 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 new file mode 100644 index 000000000..945dd5677 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460002.a @@ -0,0 +1,330 @@ +-- 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 new file mode 100644 index 000000000..b00428121 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460004.a @@ -0,0 +1,335 @@ +-- 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 new file mode 100644 index 000000000..95b14a9a2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460005.a @@ -0,0 +1,260 @@ +-- 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 new file mode 100644 index 000000000..99968847b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460006.a @@ -0,0 +1,378 @@ +-- 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 new file mode 100644 index 000000000..fdcc1adcc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460007.a @@ -0,0 +1,239 @@ +-- 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 new file mode 100644 index 000000000..29d48ecd4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460008.a @@ -0,0 +1,286 @@ +-- 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 new file mode 100644 index 000000000..62dbd47c2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460009.a @@ -0,0 +1,467 @@ +-- 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 new file mode 100644 index 000000000..790a8c339 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460010.a @@ -0,0 +1,354 @@ +-- 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 new file mode 100644 index 000000000..56e4c0c4e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460011.a @@ -0,0 +1,210 @@ +-- 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 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 new file mode 100644 index 000000000..0fb32060a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460012.a @@ -0,0 +1,93 @@ +-- 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/c46011a.ada b/gcc/testsuite/ada/acats/tests/c4/c46011a.ada new file mode 100644 index 000000000..16a1df6c7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46011a.ada @@ -0,0 +1,145 @@ +-- 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 new file mode 100644 index 000000000..b9fa7d069 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46013a.ada @@ -0,0 +1,260 @@ +-- 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 new file mode 100644 index 000000000..9f47479df --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46014a.ada @@ -0,0 +1,287 @@ +-- 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 new file mode 100644 index 000000000..198fc7ca6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46021a.ada @@ -0,0 +1,210 @@ +-- 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 new file mode 100644 index 000000000..6f0714f42 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46024a.ada @@ -0,0 +1,136 @@ +-- 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 new file mode 100644 index 000000000..589833c19 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46031a.ada @@ -0,0 +1,85 @@ +-- 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 new file mode 100644 index 000000000..a89e11598 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46032a.ada @@ -0,0 +1,103 @@ +-- 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 new file mode 100644 index 000000000..7657854e8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46033a.ada @@ -0,0 +1,110 @@ +-- 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 new file mode 100644 index 000000000..a9fd5d734 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46041a.ada @@ -0,0 +1,141 @@ +-- 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 new file mode 100644 index 000000000..2099ca6bb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46042a.ada @@ -0,0 +1,146 @@ +-- 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 new file mode 100644 index 000000000..ee973a605 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46043b.ada @@ -0,0 +1,148 @@ +-- 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 new file mode 100644 index 000000000..90ea0e494 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46044b.ada @@ -0,0 +1,235 @@ +-- 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 new file mode 100644 index 000000000..9468e8f76 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46051a.ada @@ -0,0 +1,414 @@ +-- 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 new file mode 100644 index 000000000..402992da4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46051b.ada @@ -0,0 +1,102 @@ +-- 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 new file mode 100644 index 000000000..c5cfd8fa7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46051c.ada @@ -0,0 +1,120 @@ +-- 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 new file mode 100644 index 000000000..7e69844ad --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46052a.ada @@ -0,0 +1,100 @@ +-- 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 new file mode 100644 index 000000000..53c17c4b9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46053a.ada @@ -0,0 +1,139 @@ +-- 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 new file mode 100644 index 000000000..f87cfa4f7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c46054a.ada @@ -0,0 +1,191 @@ +-- 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 new file mode 100644 index 000000000..2d583706e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460a01.a @@ -0,0 +1,408 @@ +-- 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 new file mode 100644 index 000000000..1d79d3a61 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c460a02.a @@ -0,0 +1,413 @@ +-- 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 new file mode 100644 index 000000000..e86498da0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47002a.ada @@ -0,0 +1,107 @@ +-- 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 new file mode 100644 index 000000000..ffa7b96dc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47002b.ada @@ -0,0 +1,115 @@ +-- 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 new file mode 100644 index 000000000..b9327e93b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47002c.ada @@ -0,0 +1,212 @@ +-- 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 new file mode 100644 index 000000000..472c20072 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47002d.ada @@ -0,0 +1,273 @@ +-- 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 new file mode 100644 index 000000000..a3bd47a63 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47003a.ada @@ -0,0 +1,115 @@ +-- 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 new file mode 100644 index 000000000..39659009d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47004a.ada @@ -0,0 +1,115 @@ +-- 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 new file mode 100644 index 000000000..f9ec93063 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47005a.ada @@ -0,0 +1,136 @@ +-- 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 new file mode 100644 index 000000000..c9587432a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47006a.ada @@ -0,0 +1,100 @@ +-- 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 new file mode 100644 index 000000000..bacc39f77 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47007a.ada @@ -0,0 +1,195 @@ +-- 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 new file mode 100644 index 000000000..b2218297f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47008a.ada @@ -0,0 +1,299 @@ +-- 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 new file mode 100644 index 000000000..2fee5194e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47009a.ada @@ -0,0 +1,254 @@ +-- 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 new file mode 100644 index 000000000..accd787d4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c47009b.ada @@ -0,0 +1,282 @@ +-- 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 new file mode 100644 index 000000000..5dd315a17 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48004a.ada @@ -0,0 +1,60 @@ +-- 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 new file mode 100644 index 000000000..0ba6c07b0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48004b.ada @@ -0,0 +1,140 @@ +-- 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 new file mode 100644 index 000000000..2b867a070 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48004c.ada @@ -0,0 +1,101 @@ +-- 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 new file mode 100644 index 000000000..9454327dc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48004d.ada @@ -0,0 +1,124 @@ +-- 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 new file mode 100644 index 000000000..22e62ba84 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48004e.ada @@ -0,0 +1,89 @@ +-- 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 new file mode 100644 index 000000000..50ab9e71e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48004f.ada @@ -0,0 +1,99 @@ +-- 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 new file mode 100644 index 000000000..13bea3af1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48005a.ada @@ -0,0 +1,121 @@ +-- 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 new file mode 100644 index 000000000..c03bde6e0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48005b.ada @@ -0,0 +1,78 @@ +-- 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 new file mode 100644 index 000000000..22c0582ac --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48006a.ada @@ -0,0 +1,96 @@ +-- 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 new file mode 100644 index 000000000..001b8897c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48006b.ada @@ -0,0 +1,236 @@ +-- 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 new file mode 100644 index 000000000..7fe88b8a6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48007a.ada @@ -0,0 +1,130 @@ +-- 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 new file mode 100644 index 000000000..117e1677e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48007b.ada @@ -0,0 +1,133 @@ +-- 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 new file mode 100644 index 000000000..fff3172d0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48007c.ada @@ -0,0 +1,162 @@ +-- 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 new file mode 100644 index 000000000..19e87aafa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48008a.ada @@ -0,0 +1,345 @@ +-- 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 new file mode 100644 index 000000000..39f564d57 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48008c.ada @@ -0,0 +1,79 @@ +-- 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 new file mode 100644 index 000000000..fa0d4075a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48009a.ada @@ -0,0 +1,104 @@ +-- 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 new file mode 100644 index 000000000..d74d90249 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48009b.ada @@ -0,0 +1,255 @@ +-- 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 new file mode 100644 index 000000000..80d18f342 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48009c.ada @@ -0,0 +1,113 @@ +-- 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 new file mode 100644 index 000000000..0c5d3d647 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48009d.ada @@ -0,0 +1,128 @@ +-- 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 new file mode 100644 index 000000000..e27319249 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48009e.ada @@ -0,0 +1,224 @@ +-- 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 new file mode 100644 index 000000000..d02e2c1fd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48009f.ada @@ -0,0 +1,99 @@ +-- 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 new file mode 100644 index 000000000..13fec942f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48009g.ada @@ -0,0 +1,209 @@ +-- 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 new file mode 100644 index 000000000..661793be3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48009h.ada @@ -0,0 +1,129 @@ +-- 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 new file mode 100644 index 000000000..d59b4ddb9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48009i.ada @@ -0,0 +1,128 @@ +-- 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 new file mode 100644 index 000000000..c384f38b5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48009j.ada @@ -0,0 +1,132 @@ +-- 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 new file mode 100644 index 000000000..15c7e2172 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48010a.ada @@ -0,0 +1,90 @@ +-- 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 new file mode 100644 index 000000000..7281fce9a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48011a.ada @@ -0,0 +1,101 @@ +-- 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 new file mode 100644 index 000000000..f85ad782f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c48012a.ada @@ -0,0 +1,75 @@ +-- 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 new file mode 100644 index 000000000..19153504c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c490001.a @@ -0,0 +1,215 @@ +-- 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 new file mode 100644 index 000000000..71169b833 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c490002.a @@ -0,0 +1,239 @@ +-- 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 new file mode 100644 index 000000000..a135b5ac3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c490003.a @@ -0,0 +1,215 @@ +-- 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 new file mode 100644 index 000000000..ebd2fde9a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c49020a.ada @@ -0,0 +1,73 @@ +-- 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 new file mode 100644 index 000000000..b58fcd468 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c49021a.ada @@ -0,0 +1,83 @@ +-- 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 new file mode 100644 index 000000000..d0cfa9d97 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c49022a.ada @@ -0,0 +1,158 @@ +-- 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 new file mode 100644 index 000000000..a7fe57e3c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c49022b.ada @@ -0,0 +1,73 @@ +-- 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 new file mode 100644 index 000000000..69822c83a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c49022c.ada @@ -0,0 +1,170 @@ +-- 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 new file mode 100644 index 000000000..052034270 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c49023a.ada @@ -0,0 +1,117 @@ +-- 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 new file mode 100644 index 000000000..df815794a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c49024a.ada @@ -0,0 +1,134 @@ +-- 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 new file mode 100644 index 000000000..be15cbde2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c49025a.ada @@ -0,0 +1,104 @@ +-- 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 new file mode 100644 index 000000000..c4cffa729 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c49026a.ada @@ -0,0 +1,59 @@ +-- 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 new file mode 100644 index 000000000..371077f45 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c4a005b.ada @@ -0,0 +1,104 @@ +-- 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 new file mode 100644 index 000000000..5ba984a7a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c4a006a.ada @@ -0,0 +1,61 @@ +-- 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 new file mode 100644 index 000000000..56850ca3e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c4a007a.tst @@ -0,0 +1,47 @@ +-- 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 new file mode 100644 index 000000000..e6dfe7e38 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c4a010a.ada @@ -0,0 +1,80 @@ +-- 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 new file mode 100644 index 000000000..31cf3d9de --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c4a010b.ada @@ -0,0 +1,82 @@ +-- 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 new file mode 100644 index 000000000..374827cc9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c4a011a.ada @@ -0,0 +1,334 @@ +-- 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 new file mode 100644 index 000000000..70c23ad94 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c4a012b.ada @@ -0,0 +1,184 @@ +-- 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 new file mode 100644 index 000000000..1f385b5b4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c4a013a.ada @@ -0,0 +1,77 @@ +-- 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 new file mode 100644 index 000000000..84aa878c5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c4/c4a014a.ada @@ -0,0 +1,86 @@ +-- 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 new file mode 100644 index 000000000..75fa271d0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c51004a.ada @@ -0,0 +1,261 @@ +-- 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 + + <> 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 + + <> <> 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 + + <> 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 + + <> 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 + + <> <> 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 + + <> 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 new file mode 100644 index 000000000..2c70049c8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52005a.ada @@ -0,0 +1,177 @@ +-- 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 new file mode 100644 index 000000000..94b55be7f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52005b.ada @@ -0,0 +1,115 @@ +-- 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 new file mode 100644 index 000000000..e064e5ca7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52005c.ada @@ -0,0 +1,79 @@ +-- 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 new file mode 100644 index 000000000..055482b9f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52005d.ada @@ -0,0 +1,182 @@ +-- 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 new file mode 100644 index 000000000..c474e21e9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52005e.ada @@ -0,0 +1,129 @@ +-- 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 new file mode 100644 index 000000000..19d58d0e4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52005f.ada @@ -0,0 +1,86 @@ +-- 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 new file mode 100644 index 000000000..ac0e8b05c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52008a.ada @@ -0,0 +1,73 @@ +-- 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 new file mode 100644 index 000000000..3d0fa8df1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52008b.ada @@ -0,0 +1,110 @@ +-- 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 new file mode 100644 index 000000000..8a46f988c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52009a.ada @@ -0,0 +1,77 @@ +-- 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 new file mode 100644 index 000000000..98577fd53 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52009b.ada @@ -0,0 +1,81 @@ +-- 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 new file mode 100644 index 000000000..ddb58f7f6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52010a.ada @@ -0,0 +1,186 @@ +-- 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 new file mode 100644 index 000000000..1f46c4da5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52011a.ada @@ -0,0 +1,170 @@ +-- 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 new file mode 100644 index 000000000..460f51835 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52011b.ada @@ -0,0 +1,180 @@ +-- 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 new file mode 100644 index 000000000..87a450040 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52101a.ada @@ -0,0 +1,81 @@ +-- 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 new file mode 100644 index 000000000..0d686edd5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52102a.ada @@ -0,0 +1,251 @@ +-- 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 new file mode 100644 index 000000000..79b304947 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52102b.ada @@ -0,0 +1,278 @@ +-- 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 new file mode 100644 index 000000000..17fdf43f9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52102c.ada @@ -0,0 +1,280 @@ +-- 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 new file mode 100644 index 000000000..fd4e41350 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52102d.ada @@ -0,0 +1,307 @@ +-- 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 new file mode 100644 index 000000000..f8fca51bc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103a.ada @@ -0,0 +1,385 @@ +-- 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 new file mode 100644 index 000000000..678ef5dbb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103b.ada @@ -0,0 +1,139 @@ +-- 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 new file mode 100644 index 000000000..fb122a76e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103c.ada @@ -0,0 +1,178 @@ +-- 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 new file mode 100644 index 000000000..fad061697 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103f.ada @@ -0,0 +1,338 @@ +-- 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 new file mode 100644 index 000000000..0a3a8f15d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103g.ada @@ -0,0 +1,142 @@ +-- 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 new file mode 100644 index 000000000..6915cb4cc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103h.ada @@ -0,0 +1,175 @@ +-- 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 new file mode 100644 index 000000000..f0d593be4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103k.ada @@ -0,0 +1,393 @@ +-- 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 new file mode 100644 index 000000000..528745ce2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103l.ada @@ -0,0 +1,145 @@ +-- 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 new file mode 100644 index 000000000..2377248b8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103m.ada @@ -0,0 +1,183 @@ +-- 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 new file mode 100644 index 000000000..7cbd7a589 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103p.ada @@ -0,0 +1,344 @@ +-- 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 new file mode 100644 index 000000000..919d037c6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103q.ada @@ -0,0 +1,143 @@ +-- 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 new file mode 100644 index 000000000..1daa11857 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103r.ada @@ -0,0 +1,181 @@ +-- 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 new file mode 100644 index 000000000..f0fa56a2a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52103x.ada @@ -0,0 +1,241 @@ +-- 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 new file mode 100644 index 000000000..c71408cc3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104a.ada @@ -0,0 +1,343 @@ +-- 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 new file mode 100644 index 000000000..d2f426189 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104b.ada @@ -0,0 +1,144 @@ +-- 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 new file mode 100644 index 000000000..34cb2aaf2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104c.ada @@ -0,0 +1,178 @@ +-- 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 new file mode 100644 index 000000000..a6e8a392e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104f.ada @@ -0,0 +1,292 @@ +-- 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 new file mode 100644 index 000000000..40f5daa99 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104g.ada @@ -0,0 +1,146 @@ +-- 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 new file mode 100644 index 000000000..8846bba24 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104h.ada @@ -0,0 +1,183 @@ +-- 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 new file mode 100644 index 000000000..f7abc7367 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104k.ada @@ -0,0 +1,347 @@ +-- 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 new file mode 100644 index 000000000..ca7ae3271 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104l.ada @@ -0,0 +1,146 @@ +-- 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 new file mode 100644 index 000000000..3227d591d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104m.ada @@ -0,0 +1,184 @@ +-- 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 new file mode 100644 index 000000000..f455519a0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104p.ada @@ -0,0 +1,292 @@ +-- 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 new file mode 100644 index 000000000..dc01ca880 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104q.ada @@ -0,0 +1,146 @@ +-- 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 new file mode 100644 index 000000000..8b9e3d466 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104r.ada @@ -0,0 +1,190 @@ +-- 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 new file mode 100644 index 000000000..3db74d7cd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104x.ada @@ -0,0 +1,222 @@ +-- 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 new file mode 100644 index 000000000..220a4a14c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c52104y.ada @@ -0,0 +1,174 @@ +-- 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 new file mode 100644 index 000000000..bda27b919 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c53007a.ada @@ -0,0 +1,139 @@ +-- 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 new file mode 100644 index 000000000..b7dbdd6e9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c540001.a @@ -0,0 +1,410 @@ +-- 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 new file mode 100644 index 000000000..cc46df8c6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a03a.ada @@ -0,0 +1,105 @@ +-- 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 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 new file mode 100644 index 000000000..c52de5003 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a04a.ada @@ -0,0 +1,75 @@ +-- 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 new file mode 100644 index 000000000..0729b802f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a07a.ada @@ -0,0 +1,111 @@ +-- 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 new file mode 100644 index 000000000..949de8112 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a13a.ada @@ -0,0 +1,109 @@ +-- 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 new file mode 100644 index 000000000..b0f3d1aea --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a13b.ada @@ -0,0 +1,105 @@ +-- 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 new file mode 100644 index 000000000..f093a44b5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a13c.ada @@ -0,0 +1,104 @@ +-- 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 new file mode 100644 index 000000000..9c71bd106 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a13d.ada @@ -0,0 +1,138 @@ +-- 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 new file mode 100644 index 000000000..4f6ab69d3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a22a.ada @@ -0,0 +1,68 @@ +-- 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 new file mode 100644 index 000000000..7acaa5e65 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a23a.ada @@ -0,0 +1,49 @@ +-- 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 new file mode 100644 index 000000000..edac9de5f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a24a.ada @@ -0,0 +1,63 @@ +-- 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 new file mode 100644 index 000000000..4515e93ca --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a24b.ada @@ -0,0 +1,58 @@ +-- 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 new file mode 100644 index 000000000..b6babb0d2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a42a.ada @@ -0,0 +1,173 @@ +-- 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 new file mode 100644 index 000000000..bcf1dcc90 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a42b.ada @@ -0,0 +1,173 @@ +-- 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 new file mode 100644 index 000000000..79a397976 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a42c.ada @@ -0,0 +1,123 @@ +-- 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 new file mode 100644 index 000000000..9394f5c56 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a42d.ada @@ -0,0 +1,104 @@ +-- 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 new file mode 100644 index 000000000..fb2216407 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a42e.ada @@ -0,0 +1,125 @@ +-- 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 new file mode 100644 index 000000000..c321ce8c8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a42f.ada @@ -0,0 +1,126 @@ +-- 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 new file mode 100644 index 000000000..ebe44f387 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c54a42g.ada @@ -0,0 +1,119 @@ +-- 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 new file mode 100644 index 000000000..ddcadcef8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b03a.ada @@ -0,0 +1,59 @@ +-- 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 new file mode 100644 index 000000000..748f192e8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b04a.ada @@ -0,0 +1,96 @@ +-- 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 new file mode 100644 index 000000000..20e8ff438 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b05a.ada @@ -0,0 +1,170 @@ +-- 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 new file mode 100644 index 000000000..524de24f7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b06a.ada @@ -0,0 +1,313 @@ +-- 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 new file mode 100644 index 000000000..4bff008dd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b06b.ada @@ -0,0 +1,188 @@ +-- 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 new file mode 100644 index 000000000..22c2ce491 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b07a.dep @@ -0,0 +1,126 @@ +-- 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 new file mode 100644 index 000000000..17c0c6b04 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b07b.dep @@ -0,0 +1,126 @@ +-- 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 new file mode 100644 index 000000000..46773d46d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b10a.ada @@ -0,0 +1,80 @@ +-- 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 new file mode 100644 index 000000000..4dae09714 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b11a.ada @@ -0,0 +1,104 @@ +-- 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 new file mode 100644 index 000000000..3d1b48846 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b11b.ada @@ -0,0 +1,86 @@ +-- 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 new file mode 100644 index 000000000..a04941962 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b15a.ada @@ -0,0 +1,207 @@ +-- 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 new file mode 100644 index 000000000..c6bf2b8f1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55b16a.ada @@ -0,0 +1,101 @@ +-- 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 new file mode 100644 index 000000000..c320edbb2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55c02a.ada @@ -0,0 +1,49 @@ +-- 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 new file mode 100644 index 000000000..c344838c6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c55c02b.ada @@ -0,0 +1,59 @@ +-- 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 new file mode 100644 index 000000000..ff368e363 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c56002a.ada @@ -0,0 +1,148 @@ +-- 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 new file mode 100644 index 000000000..8ca95e52e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c57003a.ada @@ -0,0 +1,334 @@ +-- 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 new file mode 100644 index 000000000..352528b92 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c57004a.ada @@ -0,0 +1,160 @@ +-- 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 new file mode 100644 index 000000000..63f5760ca --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c57004b.ada @@ -0,0 +1,162 @@ +-- 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 new file mode 100644 index 000000000..dcb66e091 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c58004c.ada @@ -0,0 +1,86 @@ +-- 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 new file mode 100644 index 000000000..c4e3ffb44 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c58004d.ada @@ -0,0 +1,90 @@ +-- 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 new file mode 100644 index 000000000..945920a9e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c58004g.ada @@ -0,0 +1,95 @@ +-- 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 new file mode 100644 index 000000000..ef6b16487 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c58005a.ada @@ -0,0 +1,121 @@ +-- 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 new file mode 100644 index 000000000..05cda7093 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c58005b.ada @@ -0,0 +1,94 @@ +-- 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 new file mode 100644 index 000000000..276d34d69 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c58005h.ada @@ -0,0 +1,172 @@ +-- 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 new file mode 100644 index 000000000..f7a2f1ca1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c58006a.ada @@ -0,0 +1,128 @@ +-- 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 new file mode 100644 index 000000000..82b313255 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c58006b.ada @@ -0,0 +1,141 @@ +-- 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 new file mode 100644 index 000000000..521071972 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c59002a.ada @@ -0,0 +1,102 @@ +-- 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 new file mode 100644 index 000000000..aee5839a7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c59002b.ada @@ -0,0 +1,209 @@ +-- 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 new file mode 100644 index 000000000..cc01a7e6c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c5/c59002c.ada @@ -0,0 +1,150 @@ +-- 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 new file mode 100644 index 000000000..eb60e89dc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c61008a.ada @@ -0,0 +1,266 @@ +-- 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 new file mode 100644 index 000000000..d98674d29 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c61009a.ada @@ -0,0 +1,160 @@ +-- 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 new file mode 100644 index 000000000..ab35f4d46 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c61010a.ada @@ -0,0 +1,246 @@ +-- 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/c62002a.ada b/gcc/testsuite/ada/acats/tests/c6/c62002a.ada new file mode 100644 index 000000000..f15bca7d2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c62002a.ada @@ -0,0 +1,190 @@ +-- 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 new file mode 100644 index 000000000..e5ab95a19 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c62003a.ada @@ -0,0 +1,234 @@ +-- 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 new file mode 100644 index 000000000..f03c774de --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c62003b.ada @@ -0,0 +1,301 @@ +-- 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 new file mode 100644 index 000000000..408a6cd6f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c62004a.ada @@ -0,0 +1,64 @@ +-- 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 new file mode 100644 index 000000000..c3ca244d4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c62006a.ada @@ -0,0 +1,70 @@ +-- 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 new file mode 100644 index 000000000..f8b0c775b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c631001.a @@ -0,0 +1,134 @@ +-- 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 new file mode 100644 index 000000000..8e259162e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c640001.a @@ -0,0 +1,334 @@ +-- 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 new file mode 100644 index 000000000..2f71f32d0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64002b.ada @@ -0,0 +1,65 @@ +-- 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 new file mode 100644 index 000000000..005a3a742 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64004g.ada @@ -0,0 +1,102 @@ +-- 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 new file mode 100644 index 000000000..af5584e9d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64005a.ada @@ -0,0 +1,64 @@ +-- 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 new file mode 100644 index 000000000..5e3f4c507 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64005b.ada @@ -0,0 +1,109 @@ +-- 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 new file mode 100644 index 000000000..ccb0a2a0e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64005c.ada @@ -0,0 +1,330 @@ +-- 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 new file mode 100644 index 000000000..adc8a0b55 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64005d0.ada @@ -0,0 +1,219 @@ +-- 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 new file mode 100644 index 000000000..33a50aa5f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64005da.ada @@ -0,0 +1,65 @@ +-- 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 new file mode 100644 index 000000000..92a5892a3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64005db.ada @@ -0,0 +1,67 @@ +-- 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 new file mode 100644 index 000000000..45e8a5ec4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64005dc.ada @@ -0,0 +1,74 @@ +-- 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 new file mode 100644 index 000000000..84ee58a7e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c641001.a @@ -0,0 +1,281 @@ +-- 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 new file mode 100644 index 000000000..3af6c6191 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64103b.ada @@ -0,0 +1,379 @@ +-- 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 new file mode 100644 index 000000000..c08ef8693 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64103c.ada @@ -0,0 +1,230 @@ +-- 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 new file mode 100644 index 000000000..180dab077 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64103d.ada @@ -0,0 +1,187 @@ +-- 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 new file mode 100644 index 000000000..7f022dfdf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64103e.ada @@ -0,0 +1,219 @@ +-- 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 new file mode 100644 index 000000000..ac26400e2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64103f.ada @@ -0,0 +1,144 @@ +-- 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 new file mode 100644 index 000000000..4a66476ca --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64104a.ada @@ -0,0 +1,215 @@ +-- 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 new file mode 100644 index 000000000..dc23f70eb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64104b.ada @@ -0,0 +1,136 @@ +-- 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 new file mode 100644 index 000000000..894182cb9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64104c.ada @@ -0,0 +1,200 @@ +-- 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 new file mode 100644 index 000000000..10dea0ef6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64104d.ada @@ -0,0 +1,93 @@ +-- 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 new file mode 100644 index 000000000..c64634613 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64104e.ada @@ -0,0 +1,82 @@ +-- 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 new file mode 100644 index 000000000..f54e1169d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64104f.ada @@ -0,0 +1,79 @@ +-- 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 new file mode 100644 index 000000000..76550651f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64104g.ada @@ -0,0 +1,93 @@ +-- 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 new file mode 100644 index 000000000..4d522806f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64104h.ada @@ -0,0 +1,111 @@ +-- 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 new file mode 100644 index 000000000..ecd24e00f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64104i.ada @@ -0,0 +1,101 @@ +-- 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 new file mode 100644 index 000000000..1577fc07b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64104j.ada @@ -0,0 +1,88 @@ +-- 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 new file mode 100644 index 000000000..8819d3ce0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64104k.ada @@ -0,0 +1,95 @@ +-- 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 new file mode 100644 index 000000000..1ecabfbbd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64104l.ada @@ -0,0 +1,109 @@ +-- 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 new file mode 100644 index 000000000..e08932120 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64104m.ada @@ -0,0 +1,95 @@ +-- 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 new file mode 100644 index 000000000..6ee8ac403 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64104n.ada @@ -0,0 +1,116 @@ +-- 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 new file mode 100644 index 000000000..5d390b0b0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64104o.ada @@ -0,0 +1,112 @@ +-- 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 new file mode 100644 index 000000000..a1739097c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64105a.ada @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..4eb217a72 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64105b.ada @@ -0,0 +1,184 @@ +-- 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 new file mode 100644 index 000000000..32fc9b635 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64105c.ada @@ -0,0 +1,230 @@ +-- 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 new file mode 100644 index 000000000..f70b49a2c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64105d.ada @@ -0,0 +1,134 @@ +-- 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 new file mode 100644 index 000000000..a74a91b68 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64106a.ada @@ -0,0 +1,351 @@ +-- 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 new file mode 100644 index 000000000..95d6fe195 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64106b.ada @@ -0,0 +1,237 @@ +-- 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 new file mode 100644 index 000000000..9adfa4d81 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64106c.ada @@ -0,0 +1,309 @@ +-- 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 new file mode 100644 index 000000000..0b3670842 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64106d.ada @@ -0,0 +1,280 @@ +-- 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 new file mode 100644 index 000000000..fd846e86d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64107a.ada @@ -0,0 +1,73 @@ +-- 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 new file mode 100644 index 000000000..ae69d6632 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64108a.ada @@ -0,0 +1,148 @@ +-- 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 new file mode 100644 index 000000000..19c3f69d2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64109a.ada @@ -0,0 +1,128 @@ +-- 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 new file mode 100644 index 000000000..a644974d6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64109b.ada @@ -0,0 +1,155 @@ +-- 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 new file mode 100644 index 000000000..1845f9e61 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64109c.ada @@ -0,0 +1,127 @@ +-- 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 new file mode 100644 index 000000000..c8469bef1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64109d.ada @@ -0,0 +1,128 @@ +-- 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 new file mode 100644 index 000000000..5860ac7d7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64109e.ada @@ -0,0 +1,156 @@ +-- 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 new file mode 100644 index 000000000..48a202c2d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64109f.ada @@ -0,0 +1,126 @@ +-- 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 new file mode 100644 index 000000000..df6a827e7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64109g.ada @@ -0,0 +1,125 @@ +-- 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 new file mode 100644 index 000000000..182856329 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64109h.ada @@ -0,0 +1,160 @@ +-- 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 new file mode 100644 index 000000000..de7ede6b0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64109i.ada @@ -0,0 +1,163 @@ +-- 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 new file mode 100644 index 000000000..c326ef2c4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64109j.ada @@ -0,0 +1,164 @@ +-- 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 new file mode 100644 index 000000000..d72d8ec6c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64109k.ada @@ -0,0 +1,191 @@ +-- 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 new file mode 100644 index 000000000..7bdb17040 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64109l.ada @@ -0,0 +1,158 @@ +-- 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 new file mode 100644 index 000000000..e550b34ca --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64201b.ada @@ -0,0 +1,101 @@ +-- 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 new file mode 100644 index 000000000..ac7fec806 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64201c.ada @@ -0,0 +1,196 @@ +-- 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 new file mode 100644 index 000000000..3c4af8ef9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c64202a.ada @@ -0,0 +1,72 @@ +-- 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 new file mode 100644 index 000000000..595e81dad --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c650001.a @@ -0,0 +1,412 @@ +-- 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 new file mode 100644 index 000000000..49cd2b55e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c65003a.ada @@ -0,0 +1,100 @@ +-- 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 new file mode 100644 index 000000000..d93d1b480 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c65003b.ada @@ -0,0 +1,73 @@ +-- 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 new file mode 100644 index 000000000..8afec993a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c66002a.ada @@ -0,0 +1,104 @@ +-- 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 new file mode 100644 index 000000000..d646f0603 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c66002c.ada @@ -0,0 +1,102 @@ +-- 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 new file mode 100644 index 000000000..fe4209894 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c66002d.ada @@ -0,0 +1,85 @@ +-- 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 new file mode 100644 index 000000000..d2b509639 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c66002e.ada @@ -0,0 +1,91 @@ +-- 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 new file mode 100644 index 000000000..a62897786 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c66002f.ada @@ -0,0 +1,92 @@ +-- 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 new file mode 100644 index 000000000..06c6ea33d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c66002g.ada @@ -0,0 +1,82 @@ +-- 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 new file mode 100644 index 000000000..da295994e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c67002a.ada @@ -0,0 +1,426 @@ +-- 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 new file mode 100644 index 000000000..d716fb33e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c67002b.ada @@ -0,0 +1,176 @@ +-- 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 new file mode 100644 index 000000000..4a40231c7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c67002c.ada @@ -0,0 +1,548 @@ +-- 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 new file mode 100644 index 000000000..3d829802f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c67002d.ada @@ -0,0 +1,354 @@ +-- 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 new file mode 100644 index 000000000..aa3695239 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c67002e.ada @@ -0,0 +1,348 @@ +-- 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 new file mode 100644 index 000000000..fde865c08 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c67003f.ada @@ -0,0 +1,319 @@ +-- 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 new file mode 100644 index 000000000..e83d8d1d0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c67005a.ada @@ -0,0 +1,96 @@ +-- 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 new file mode 100644 index 000000000..27579605d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c67005b.ada @@ -0,0 +1,124 @@ +-- 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 new file mode 100644 index 000000000..b52c40d64 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c67005c.ada @@ -0,0 +1,109 @@ +-- 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 new file mode 100644 index 000000000..95eafe243 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c6/c67005d.ada @@ -0,0 +1,78 @@ +-- 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 new file mode 100644 index 000000000..41a1a2c6e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c72001b.ada @@ -0,0 +1,96 @@ +-- 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 new file mode 100644 index 000000000..491f074f3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c72002a.ada @@ -0,0 +1,229 @@ +-- 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 new file mode 100644 index 000000000..24cf8e0fd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c730001.a @@ -0,0 +1,437 @@ +-- 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 new file mode 100644 index 000000000..9213a7d92 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c730002.a @@ -0,0 +1,383 @@ +-- 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 new file mode 100644 index 000000000..47002f3aa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c730003.a @@ -0,0 +1,283 @@ +-- 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 new file mode 100644 index 000000000..c2a23230a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c730004.a @@ -0,0 +1,327 @@ +-- 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 new file mode 100644 index 000000000..8bbc4afb0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c73002a.ada @@ -0,0 +1,110 @@ +-- 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 new file mode 100644 index 000000000..43f16f928 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c730a01.a @@ -0,0 +1,176 @@ +-- 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 new file mode 100644 index 000000000..97d04b6db --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c730a02.a @@ -0,0 +1,252 @@ +-- 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 new file mode 100644 index 000000000..0cfce32bc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c731001.a @@ -0,0 +1,407 @@ +-- 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 new file mode 100644 index 000000000..f2a016b09 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74004a.ada @@ -0,0 +1,375 @@ +-- 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 new file mode 100644 index 000000000..82cfe9269 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74203a.ada @@ -0,0 +1,263 @@ +-- 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 new file mode 100644 index 000000000..6a0dfbfc6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74206a.ada @@ -0,0 +1,144 @@ +-- 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 new file mode 100644 index 000000000..a5284a6de --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74207b.ada @@ -0,0 +1,75 @@ +-- 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 new file mode 100644 index 000000000..36607d285 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74208a.ada @@ -0,0 +1,116 @@ +-- 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 new file mode 100644 index 000000000..c4c00bfc3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74208b.ada @@ -0,0 +1,106 @@ +-- 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 new file mode 100644 index 000000000..eef77fde9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74209a.ada @@ -0,0 +1,224 @@ +-- 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 new file mode 100644 index 000000000..f3496b31c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74210a.ada @@ -0,0 +1,117 @@ +-- 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 new file mode 100644 index 000000000..d4a1caf05 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74211a.ada @@ -0,0 +1,195 @@ +-- 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 new file mode 100644 index 000000000..d4b9ef73f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74211b.ada @@ -0,0 +1,156 @@ +-- 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 new file mode 100644 index 000000000..a772e5087 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74302a.ada @@ -0,0 +1,81 @@ +-- 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 new file mode 100644 index 000000000..16b0803cd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74302b.ada @@ -0,0 +1,308 @@ +-- 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 new file mode 100644 index 000000000..b1233cbd1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74305a.ada @@ -0,0 +1,160 @@ +-- 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 new file mode 100644 index 000000000..fa9ae1ea4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74305b.ada @@ -0,0 +1,101 @@ +-- 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 new file mode 100644 index 000000000..c6ebad3c8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74306a.ada @@ -0,0 +1,279 @@ +-- 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 new file mode 100644 index 000000000..aaddc0505 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74307a.ada @@ -0,0 +1,58 @@ +-- 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 new file mode 100644 index 000000000..024e677ba --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74401d.ada @@ -0,0 +1,111 @@ +-- 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 new file mode 100644 index 000000000..df0c99007 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74401e.ada @@ -0,0 +1,120 @@ +-- 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 new file mode 100644 index 000000000..55f153e0d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74401k.ada @@ -0,0 +1,136 @@ +-- 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 new file mode 100644 index 000000000..7576721a2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74401q.ada @@ -0,0 +1,119 @@ +-- 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 new file mode 100644 index 000000000..3dac5c75a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74402a.ada @@ -0,0 +1,154 @@ +-- 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 new file mode 100644 index 000000000..45597a908 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74402b.ada @@ -0,0 +1,103 @@ +-- 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 new file mode 100644 index 000000000..69ddd41b5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74406a.ada @@ -0,0 +1,130 @@ +-- 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 new file mode 100644 index 000000000..d8f65084c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74407b.ada @@ -0,0 +1,195 @@ +-- 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 new file mode 100644 index 000000000..0bd2a065b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c74409b.ada @@ -0,0 +1,93 @@ +-- 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 new file mode 100644 index 000000000..be9ff8194 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c760001.a @@ -0,0 +1,390 @@ +-- 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 new file mode 100644 index 000000000..4601873be --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c760002.a @@ -0,0 +1,489 @@ +-- 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 new file mode 100644 index 000000000..c1ddfcb93 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c760007.a @@ -0,0 +1,247 @@ +-- 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 new file mode 100644 index 000000000..8c3b80b36 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c760009.a @@ -0,0 +1,533 @@ +-- 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 new file mode 100644 index 000000000..08fe62b9f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c760010.a @@ -0,0 +1,418 @@ +-- 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 new file mode 100644 index 000000000..8df37fa3c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c760011.a @@ -0,0 +1,291 @@ +-- 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 new file mode 100644 index 000000000..08986a838 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c760012.a @@ -0,0 +1,256 @@ +-- 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 new file mode 100644 index 000000000..6921bf027 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c760013.a @@ -0,0 +1,108 @@ +-- 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 new file mode 100644 index 000000000..7be1ee07a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c761001.a @@ -0,0 +1,117 @@ +-- 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 new file mode 100644 index 000000000..5b807bba7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c761002.a @@ -0,0 +1,245 @@ +-- 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; +<> + 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 new file mode 100644 index 000000000..77051ee4a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c761003.a @@ -0,0 +1,447 @@ +-- 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 new file mode 100644 index 000000000..9b88382b4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c761004.a @@ -0,0 +1,305 @@ +-- 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 new file mode 100644 index 000000000..acac59b48 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c761005.a @@ -0,0 +1,288 @@ +-- 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 new file mode 100644 index 000000000..771e625d1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c761006.a @@ -0,0 +1,425 @@ +-- 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 are +-- performed", where ::= 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. +-- +--! + +------------------------------------------------------------- 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 + + type Shark is access C761006_2.Fin_Check; + + procedure Catch is + new Unchecked_Deallocation( C761006_2.Fin_Check, Shark ); + + procedure Finalize_17 is + White : Shark := new C761006_2.Fin_Check; + begin + Catch( White ); + 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; + + begin + + Exception_In_Finalization: begin + Finalize_15; + exception + when Program_Error => null; -- anticipated + end Exception_In_Finalization; + + Use_Of_Unchecked_Deallocation: begin + Finalize_17; + exception + when others => + Report.Failed("Unchecked_Deallocation check, unwanted exception"); + 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 new file mode 100644 index 000000000..7b3dbfb9b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c761007.a @@ -0,0 +1,419 @@ +-- 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 new file mode 100644 index 000000000..7784c6da5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c761010.a @@ -0,0 +1,447 @@ +-- 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 new file mode 100644 index 000000000..1d447c755 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c761011.a @@ -0,0 +1,410 @@ +-- 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; + <> + 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 new file mode 100644 index 000000000..77b9e2253 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c761012.a @@ -0,0 +1,151 @@ +-- 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 new file mode 100644 index 000000000..f33d907af --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83007a.ada @@ -0,0 +1,95 @@ +-- 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 new file mode 100644 index 000000000..a73639c6c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83012d.ada @@ -0,0 +1,116 @@ +-- 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 new file mode 100644 index 000000000..391c9dda5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83022a.ada @@ -0,0 +1,338 @@ +-- 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 new file mode 100644 index 000000000..36f3f9065 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83022g0.ada @@ -0,0 +1,165 @@ +-- 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 new file mode 100644 index 000000000..e25bdc982 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83022g1.ada @@ -0,0 +1,189 @@ +-- 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 new file mode 100644 index 000000000..18f80c3c0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83023a.ada @@ -0,0 +1,194 @@ +-- 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 new file mode 100644 index 000000000..0ad06b3a1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83024a.ada @@ -0,0 +1,185 @@ +-- 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 new file mode 100644 index 000000000..e92cffb9d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83024e0.ada @@ -0,0 +1,112 @@ +-- 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 new file mode 100644 index 000000000..d7c1c5b23 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83024e1.ada @@ -0,0 +1,220 @@ +-- 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 new file mode 100644 index 000000000..aff1914eb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83025a.ada @@ -0,0 +1,283 @@ +-- 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 new file mode 100644 index 000000000..b21d26898 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83025c.ada @@ -0,0 +1,345 @@ +-- 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 new file mode 100644 index 000000000..ba7c12386 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83027a.ada @@ -0,0 +1,188 @@ +-- 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 new file mode 100644 index 000000000..2950135d1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83027c.ada @@ -0,0 +1,157 @@ +-- 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 new file mode 100644 index 000000000..7aa7af033 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83028a.ada @@ -0,0 +1,156 @@ +-- 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 new file mode 100644 index 000000000..1460a5317 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83029a.ada @@ -0,0 +1,110 @@ +-- 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 new file mode 100644 index 000000000..d992f7b28 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83030a.ada @@ -0,0 +1,234 @@ +-- 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 new file mode 100644 index 000000000..914bd6465 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83030c.ada @@ -0,0 +1,263 @@ +-- 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 new file mode 100644 index 000000000..13b90bbc5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83031a.ada @@ -0,0 +1,163 @@ +-- 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 new file mode 100644 index 000000000..1327a2546 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83031c.ada @@ -0,0 +1,101 @@ +-- 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 new file mode 100644 index 000000000..7742678af --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83031e.ada @@ -0,0 +1,70 @@ +-- 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 new file mode 100644 index 000000000..b1920ee21 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83032a.ada @@ -0,0 +1,111 @@ +-- 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 new file mode 100644 index 000000000..6cfca9326 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83033a.ada @@ -0,0 +1,146 @@ +-- 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"); + + <> 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 new file mode 100644 index 000000000..0dc215260 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83051a.ada @@ -0,0 +1,397 @@ +-- 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 new file mode 100644 index 000000000..c982d3f9a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83b02a.ada @@ -0,0 +1,79 @@ +-- 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 new file mode 100644 index 000000000..817647a94 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83b02b.ada @@ -0,0 +1,112 @@ +-- 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 new file mode 100644 index 000000000..a99c70b46 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83e02a.ada @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..ba157672f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83e02b.ada @@ -0,0 +1,65 @@ +-- 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 new file mode 100644 index 000000000..0a46f34dd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83e03a.ada @@ -0,0 +1,81 @@ +-- 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 new file mode 100644 index 000000000..abf1d7499 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f01a.ada @@ -0,0 +1,109 @@ +-- 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 new file mode 100644 index 000000000..3dca9fc9a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f01b.ada @@ -0,0 +1,129 @@ +-- 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 new file mode 100644 index 000000000..9b8c2da17 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f01c0.ada @@ -0,0 +1,55 @@ +-- 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 new file mode 100644 index 000000000..bd27d1671 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f01c1.ada @@ -0,0 +1,69 @@ +-- 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 new file mode 100644 index 000000000..dbce105fe --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f01c2.ada @@ -0,0 +1,69 @@ +-- 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 new file mode 100644 index 000000000..c73f0bce9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f01d0.ada @@ -0,0 +1,103 @@ +-- 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 new file mode 100644 index 000000000..fb0d9f508 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f01d1.ada @@ -0,0 +1,57 @@ +-- 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 new file mode 100644 index 000000000..a24f03863 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f03a.ada @@ -0,0 +1,113 @@ +-- 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 ; + + <> BUMP ; GOTO X2 ; + BUMP ; + <> BUMP ; GOTO Z ; + BUMP ; + <> BUMP ; GOTO Y2 ; + BUMP ; + <> BUMP ; GOTO T1 ; + BUMP ; + <> BUMP ; GOTO Y1 ; + BUMP ; + <> 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 new file mode 100644 index 000000000..4b5afea76 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f03b.ada @@ -0,0 +1,157 @@ +-- 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 ; + + <> BUMP ; GOTO X2 ; + BUMP ; + <> BUMP ; GOTO Z ; + BUMP ; + <> BUMP ; GOTO Y2 ; + BUMP ; + <> BUMP ; GOTO T1 ; + BUMP ; + <> BUMP ; GOTO Y1 ; + BUMP ; + <> BUMP ; GOTO T3 ; + BUMP ; + <> BUMP ; GOTO T4 ; + BUMP ; + <> BUMP ; GOTO LABEL_IN_MAIN ; + BUMP ; + <> BUMP ; GOTO Y4 ; + BUMP ; + <> BUMP ; GOTO LABEL_IN_OUTER ; + BUMP ; + <> BUMP ; GOTO Y3 ; + BUMP ; + <> 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 new file mode 100644 index 000000000..15962eb50 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f03c0.ada @@ -0,0 +1,53 @@ +-- 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 new file mode 100644 index 000000000..fa4dbf037 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f03c1.ada @@ -0,0 +1,81 @@ +-- 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 ; + + <> BUMP ; GOTO T4 ; + BUMP ; + <> BUMP ; GOTO ENDING ; + BUMP ; + <> BUMP ; GOTO Y4 ; + BUMP ; + <> BUMP ; GOTO LABEL_IN_OUTER ; + BUMP ; + <> 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 new file mode 100644 index 000000000..978f834bf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f03c2.ada @@ -0,0 +1,64 @@ +-- 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 new file mode 100644 index 000000000..e2ecd76fd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f03d0.ada @@ -0,0 +1,89 @@ +-- 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 new file mode 100644 index 000000000..aac2cf939 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c83f03d1.ada @@ -0,0 +1,82 @@ +-- 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 ; + + <> BUMP ; GOTO T3 ; + BUMP ; + <> BUMP ; GOTO Z ; + BUMP ; + <> BUMP ; GOTO LABEL_IN_MAIN ; + BUMP ; + <> BUMP ; GOTO T1 ; + BUMP ; + <> BUMP ; GOTO Y1 ; + BUMP ; + <> BUMP ; GOTO T4 ; + BUMP ; + <> BUMP ; GOTO ENDING ; + BUMP ; + <> BUMP ; GOTO Y4 ; + BUMP ; + <> BUMP ; GOTO LABEL_IN_OUTER ; + BUMP ; + <> 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 new file mode 100644 index 000000000..2a1df1640 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c840001.a @@ -0,0 +1,257 @@ +-- 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 new file mode 100644 index 000000000..ed421e9bc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c84002a.ada @@ -0,0 +1,267 @@ +-- 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 new file mode 100644 index 000000000..53bd64a3d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c84005a.ada @@ -0,0 +1,117 @@ +-- 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 new file mode 100644 index 000000000..fb760eddc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c84008a.ada @@ -0,0 +1,83 @@ +-- 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 new file mode 100644 index 000000000..afc5fe0da --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c84009a.ada @@ -0,0 +1,99 @@ +-- 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 new file mode 100644 index 000000000..515936fe9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85004b.ada @@ -0,0 +1,164 @@ +-- 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 new file mode 100644 index 000000000..05dc328bd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85005a.ada @@ -0,0 +1,391 @@ +-- 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 new file mode 100644 index 000000000..9c4f6fe96 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85005b.ada @@ -0,0 +1,366 @@ +-- 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 new file mode 100644 index 000000000..fe2acb035 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85005c.ada @@ -0,0 +1,416 @@ +-- 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 new file mode 100644 index 000000000..c745aee44 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85005d.ada @@ -0,0 +1,378 @@ +-- 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 new file mode 100644 index 000000000..1f6ffc37d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85005e.ada @@ -0,0 +1,397 @@ +-- 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 new file mode 100644 index 000000000..adc87f996 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85005f.ada @@ -0,0 +1,71 @@ +-- 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 new file mode 100644 index 000000000..2c1f7f02a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85005g.ada @@ -0,0 +1,145 @@ +-- 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 new file mode 100644 index 000000000..be04e4dbe --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85006a.ada @@ -0,0 +1,681 @@ +-- 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 new file mode 100644 index 000000000..885d8393a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85006b.ada @@ -0,0 +1,699 @@ +-- 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 new file mode 100644 index 000000000..74a7dbfb5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85006c.ada @@ -0,0 +1,778 @@ +-- 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 new file mode 100644 index 000000000..b93640214 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85006d.ada @@ -0,0 +1,712 @@ +-- 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 new file mode 100644 index 000000000..3c920039d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85006e.ada @@ -0,0 +1,702 @@ +-- 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 new file mode 100644 index 000000000..bbfe63e92 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85006f.ada @@ -0,0 +1,70 @@ +-- 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 new file mode 100644 index 000000000..9d6d59f5e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85006g.ada @@ -0,0 +1,136 @@ +-- 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 new file mode 100644 index 000000000..87eda143f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85007a.ada @@ -0,0 +1,115 @@ +-- 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 new file mode 100644 index 000000000..da1f9559c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85007e.ada @@ -0,0 +1,102 @@ +-- 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 new file mode 100644 index 000000000..23d3c60d2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85009a.ada @@ -0,0 +1,109 @@ +-- 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 new file mode 100644 index 000000000..538f9c235 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85011a.ada @@ -0,0 +1,145 @@ +-- 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 new file mode 100644 index 000000000..9877760e4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85013a.ada @@ -0,0 +1,150 @@ +-- 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 new file mode 100644 index 000000000..cd924ac80 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85014a.ada @@ -0,0 +1,142 @@ +-- 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 new file mode 100644 index 000000000..ba195613e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85014b.ada @@ -0,0 +1,192 @@ +-- 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 new file mode 100644 index 000000000..6e91f8f63 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85014c.ada @@ -0,0 +1,118 @@ +-- 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 new file mode 100644 index 000000000..4424a6582 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85017a.ada @@ -0,0 +1,61 @@ +-- 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 new file mode 100644 index 000000000..e82680818 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85018a.ada @@ -0,0 +1,140 @@ +-- 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 new file mode 100644 index 000000000..44fbb5668 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85018b.ada @@ -0,0 +1,288 @@ +-- 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 new file mode 100644 index 000000000..6aec3ae67 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c85019a.ada @@ -0,0 +1,59 @@ +-- 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 new file mode 100644 index 000000000..5a128ba69 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c854001.a @@ -0,0 +1,277 @@ +-- 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 new file mode 100644 index 000000000..19bca3598 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c854002.a @@ -0,0 +1,185 @@ +-- 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 new file mode 100644 index 000000000..9ab2364a9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c854003.a @@ -0,0 +1,64 @@ +-- 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 new file mode 100644 index 000000000..92b36638e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c86003a.ada @@ -0,0 +1,122 @@ +-- 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 new file mode 100644 index 000000000..937e5f3fb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c86004a.ada @@ -0,0 +1,100 @@ +-- 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 new file mode 100644 index 000000000..5b9d7c533 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c86004b0.ada @@ -0,0 +1,44 @@ +-- 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 new file mode 100644 index 000000000..09ae4faf6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c86004b1.ada @@ -0,0 +1,53 @@ +-- 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 new file mode 100644 index 000000000..cb9cd23a0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c86004b2.ada @@ -0,0 +1,46 @@ +-- 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 new file mode 100644 index 000000000..f3a1b3e71 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c86004c0.ada @@ -0,0 +1,60 @@ +-- 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 new file mode 100644 index 000000000..b896a8e26 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c86004c1.ada @@ -0,0 +1,50 @@ +-- 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 new file mode 100644 index 000000000..ffe1e0592 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c86004c2.ada @@ -0,0 +1,45 @@ +-- 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 new file mode 100644 index 000000000..38778f97c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c86006i.ada @@ -0,0 +1,103 @@ +-- 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 new file mode 100644 index 000000000..ba41e176c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c86007a.ada @@ -0,0 +1,79 @@ +-- 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 new file mode 100644 index 000000000..8efbbdeec --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87a05a.ada @@ -0,0 +1,108 @@ +-- 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 new file mode 100644 index 000000000..7d99c9578 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87a05b.ada @@ -0,0 +1,107 @@ +-- 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 new file mode 100644 index 000000000..9f789c9b2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b02a.ada @@ -0,0 +1,124 @@ +-- 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 new file mode 100644 index 000000000..5f2db7c40 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b02b.ada @@ -0,0 +1,124 @@ +-- 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 new file mode 100644 index 000000000..d0b372237 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b03a.ada @@ -0,0 +1,61 @@ +-- 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 new file mode 100644 index 000000000..ea2e65c1a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b04a.ada @@ -0,0 +1,79 @@ +-- 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 new file mode 100644 index 000000000..681011ba3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b04b.ada @@ -0,0 +1,82 @@ +-- 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 new file mode 100644 index 000000000..df67059b5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b04c.ada @@ -0,0 +1,60 @@ +-- 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 new file mode 100644 index 000000000..f50ce379b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b05a.ada @@ -0,0 +1,70 @@ +-- 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 new file mode 100644 index 000000000..a5c64b4b4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b06a.ada @@ -0,0 +1,90 @@ +-- 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 new file mode 100644 index 000000000..635a8fc65 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b07a.ada @@ -0,0 +1,64 @@ +-- 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 new file mode 100644 index 000000000..ec2c0a193 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b07b.ada @@ -0,0 +1,101 @@ +-- 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 new file mode 100644 index 000000000..851143a50 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b07c.ada @@ -0,0 +1,85 @@ +-- 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 new file mode 100644 index 000000000..0e93649d7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b07d.ada @@ -0,0 +1,59 @@ +-- 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 new file mode 100644 index 000000000..83e5c906a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b07e.ada @@ -0,0 +1,69 @@ +-- 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 new file mode 100644 index 000000000..b9998455e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b08a.ada @@ -0,0 +1,72 @@ +-- 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 new file mode 100644 index 000000000..bcdcad642 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b09a.ada @@ -0,0 +1,55 @@ +-- 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 new file mode 100644 index 000000000..4a7ce12cd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b09c.ada @@ -0,0 +1,64 @@ +-- 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 new file mode 100644 index 000000000..a09db6052 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b10a.ada @@ -0,0 +1,75 @@ +-- 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 new file mode 100644 index 000000000..07a373723 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b11a.ada @@ -0,0 +1,55 @@ +-- 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 new file mode 100644 index 000000000..654603aff --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b11b.ada @@ -0,0 +1,57 @@ +-- 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 new file mode 100644 index 000000000..c46b6f093 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b13a.ada @@ -0,0 +1,71 @@ +-- 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 new file mode 100644 index 000000000..1ef05163e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b14a.ada @@ -0,0 +1,87 @@ +-- 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 new file mode 100644 index 000000000..2d6a512fc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b14b.ada @@ -0,0 +1,90 @@ +-- 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 new file mode 100644 index 000000000..9bdb041c9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b14c.ada @@ -0,0 +1,89 @@ +-- 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 new file mode 100644 index 000000000..cf1c4d3df --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b14d.ada @@ -0,0 +1,63 @@ +-- 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 new file mode 100644 index 000000000..92a14de89 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b15a.ada @@ -0,0 +1,108 @@ +-- 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 new file mode 100644 index 000000000..307ca0e05 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b16a.ada @@ -0,0 +1,129 @@ +-- 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 new file mode 100644 index 000000000..96405d631 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b17a.ada @@ -0,0 +1,130 @@ +-- 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 new file mode 100644 index 000000000..fdb2ad352 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b18a.ada @@ -0,0 +1,82 @@ +-- 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 new file mode 100644 index 000000000..f0824b94b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b18b.ada @@ -0,0 +1,83 @@ +-- 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 new file mode 100644 index 000000000..aa1960d19 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b19a.ada @@ -0,0 +1,110 @@ +-- 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 new file mode 100644 index 000000000..5cfa1d825 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b23a.ada @@ -0,0 +1,100 @@ +-- 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 new file mode 100644 index 000000000..abfaad633 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b24a.ada @@ -0,0 +1,79 @@ +-- 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 new file mode 100644 index 000000000..537cf9b48 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b24b.ada @@ -0,0 +1,98 @@ +-- 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 new file mode 100644 index 000000000..41f6ca4f5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b26b.ada @@ -0,0 +1,149 @@ +-- 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 new file mode 100644 index 000000000..4b99792cd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b27a.ada @@ -0,0 +1,80 @@ +-- 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 new file mode 100644 index 000000000..dfde694bb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b28a.ada @@ -0,0 +1,71 @@ +-- 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 new file mode 100644 index 000000000..594f71987 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b29a.ada @@ -0,0 +1,72 @@ +-- 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 new file mode 100644 index 000000000..da574513e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b30a.ada @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..7aebd41dd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b31a.ada @@ -0,0 +1,137 @@ +-- 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 new file mode 100644 index 000000000..1a31f113d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b32a.ada @@ -0,0 +1,199 @@ +-- 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 new file mode 100644 index 000000000..5c398d463 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b33a.ada @@ -0,0 +1,117 @@ +-- 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 new file mode 100644 index 000000000..4291197af --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b34a.ada @@ -0,0 +1,68 @@ +-- 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 new file mode 100644 index 000000000..17cdbcea0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b34b.ada @@ -0,0 +1,71 @@ +-- 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 new file mode 100644 index 000000000..7b8dc5930 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b34c.ada @@ -0,0 +1,75 @@ +-- 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 new file mode 100644 index 000000000..89a839f6d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b35c.ada @@ -0,0 +1,82 @@ +-- 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 new file mode 100644 index 000000000..46ba65185 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b38a.ada @@ -0,0 +1,76 @@ +-- 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 new file mode 100644 index 000000000..75c855962 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b39a.ada @@ -0,0 +1,106 @@ +-- 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 new file mode 100644 index 000000000..5fd04a16b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b40a.ada @@ -0,0 +1,106 @@ +-- 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 new file mode 100644 index 000000000..ae60c8d51 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b41a.ada @@ -0,0 +1,112 @@ +-- 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 new file mode 100644 index 000000000..9365d5852 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b42a.ada @@ -0,0 +1,77 @@ +-- 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 new file mode 100644 index 000000000..9bb11fd6e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b43a.ada @@ -0,0 +1,60 @@ +-- 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 new file mode 100644 index 000000000..66acd0340 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b44a.ada @@ -0,0 +1,112 @@ +-- 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 new file mode 100644 index 000000000..497de84f7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b45a.ada @@ -0,0 +1,126 @@ +-- 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 new file mode 100644 index 000000000..d70687a7e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b45c.ada @@ -0,0 +1,148 @@ +-- 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 new file mode 100644 index 000000000..c9a426f10 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b47a.ada @@ -0,0 +1,74 @@ +-- 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 new file mode 100644 index 000000000..d8d79b5c3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b48a.ada @@ -0,0 +1,94 @@ +-- 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 new file mode 100644 index 000000000..45037ecd9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b48b.ada @@ -0,0 +1,72 @@ +-- 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 new file mode 100644 index 000000000..ee287af1d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b50a.ada @@ -0,0 +1,64 @@ +-- 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 new file mode 100644 index 000000000..26b4b1498 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b54a.ada @@ -0,0 +1,87 @@ +-- 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 new file mode 100644 index 000000000..31d3b8ad5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b57a.ada @@ -0,0 +1,134 @@ +-- 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 new file mode 100644 index 000000000..550d20bbf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b62a.ada @@ -0,0 +1,79 @@ +-- 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 new file mode 100644 index 000000000..2b03442a5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b62b.ada @@ -0,0 +1,99 @@ +-- 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 new file mode 100644 index 000000000..fb5d4ef60 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b62c.ada @@ -0,0 +1,80 @@ +-- 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 new file mode 100644 index 000000000..296402a6d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c8/c87b62d.tst @@ -0,0 +1,105 @@ +-- 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 new file mode 100644 index 000000000..416e13ca8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c910001.a @@ -0,0 +1,224 @@ +-- C910001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that tasks may have discriminants. Specifically, check where +-- the subtype of the discriminant is a discrete subtype and where it is +-- an access subtype. Check the case where the default values of the +-- discriminants are used. +-- +-- TEST DESCRIPTION: +-- A task is defined with two discriminants, one a discrete subtype and +-- another that is an access subtype. Tasks are created with various +-- values for discriminants and code within the task checks that these +-- are passed in correctly. One instance of a default is used. The +-- values passed to the task as the discriminants are taken from an +-- array of test data and the values received are checked against the +-- same array. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; + +procedure C910001 is + + + type App_Priority is range 1..10; + Default_Priority : App_Priority := 5; + + type Message_ID is range 1..10_000; + + type TC_Number_of_Messages is range 1..5; + + type TC_rec is record + TC_ID : Message_ID; + A_Priority : App_Priority; + TC_Checked : Boolean; + end record; + + -- This table is used to create the messages and to check them + TC_table : array (1..TC_Number_of_Messages'Last) of TC_Rec := + ( ( 10, 6, false ), + ( 20, 2, false ), + ( 30, 9, false ), + ( 40, 1, false ), + ( 50, Default_Priority, false ) ); + +begin -- C910001 + + Report.Test ("C910001", "Check that tasks may have discriminants"); + + + declare -- encapsulate the test + + type Transaction_Record is + record + ID : Message_ID; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + end record; + -- + type acc_Transaction_Record is access Transaction_Record; + + + task type Message_Task + (In_Message : acc_Transaction_Record := null; + In_Priority : App_Priority := Default_Priority) is + entry Start; + end Message_Task; + type acc_Message_Task is access Message_Task; + -- + -- + task body Message_Task is + This_Message : acc_Transaction_Record := In_Message; + This_Priority : App_Priority := In_Priority; + TC_Match_Found : Boolean := false; + begin + accept Start; + -- In the example envisioned this task would then queue itself + -- upon some Distributor task which would send it off (requeue) to + -- the message processing tasks according to the priority of the + -- message and the current load on the system. For the test we + -- just verify the data passed in as discriminants and exit the task + -- + -- Check for the special case of default discriminants + if This_Message = null then + -- The default In_Message has been passed, check that the + -- default priority was also passed + if This_Priority /= Default_Priority then + Report.Failed ("Incorrect Default Priority"); + end if; + if TC_Table (TC_Number_of_Messages'Last).TC_Checked then + Report.Failed ("Duplicate Default messages"); + else + -- Mark that default has been seen + TC_Table (TC_Number_of_Messages'Last).TC_Checked := True; + end if; + TC_Match_Found := true; + else + -- Check the data against the table + for i in TC_Number_of_Messages loop + if TC_Table(i).TC_ID = This_Message.ID then + -- this is the right slot in the table + if TC_Table(i).TC_checked then + -- Already checked + Report.Failed ("Duplicate Data"); + else + TC_Table(i).TC_checked := true; + end if; + TC_Match_Found := true; + if TC_Table(i).A_Priority /= This_Priority then + Report.Failed ("ID/Priority mismatch"); + end if; + exit; + end if; + end loop; + end if; + + if not TC_Match_Found then + Report.Failed ("No ID match in table"); + end if; + + -- Allow the task to terminate + + end Message_Task; + + + -- The Line Driver task accepts data from an external source and + -- builds them into a transaction record. It then generates a + -- message task. This message "contains" the record and is given + -- a priority according to the contents of the message. The priority + -- and transaction records are passed to the task as discriminants. + -- In this test we use a dummy record. Only the ID is of interest + -- so we pick that and the required priority from an array of + -- test data. We artificially limit the endless driver-loop to + -- the number of messages required for the test and add a special + -- case to check the defaults. + -- + task Driver_Task; + -- + task body Driver_Task is + begin + + -- Create all but one of the required tasks + -- + for i in 1..TC_Number_of_Messages'Last - 1 loop + declare + -- Create a record for the next message + Next_Transaction : acc_Transaction_Record := + new Transaction_Record; + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := + new Message_Task( Next_Transaction, + TC_Table(i).A_Priority ); + + begin + -- Artificially plug the ID with the next from the table + -- In reality the whole record would be built here + Next_Transaction.ID := TC_Table(i).TC_ID; + + -- Ensure the task does not start executing till the + -- transaction record is properly constructed + Next_Message_Task.Start; + + end; -- declare + end loop; + + -- For this subtest create one task with the default discriminants + -- + declare + + -- Create the task + Next_Message_Task : acc_Message_Task := new Message_Task; + + begin + + Next_Message_Task.Start; + + end; -- declare + + + end Driver_Task; + + begin + null; + end; -- encapsulation + + -- Now verify that all the tasks executed and checked in + for i in TC_Number_of_Messages loop + if not TC_Table(i).TC_Checked then + Report.Failed + ("Task" & integer'image(integer (i) ) & " did not verify"); + end if; + end loop; + Report.Result; + +end C910001; diff --git a/gcc/testsuite/ada/acats/tests/c9/c910002.a b/gcc/testsuite/ada/acats/tests/c9/c910002.a new file mode 100644 index 000000000..dc0b9b36b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c910002.a @@ -0,0 +1,143 @@ +-- C910002.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the contents of a task object include the values +-- of its discriminants. +-- Check that selected_component notation can be used to +-- denote a discriminant of a task. +-- +-- TEST DESCRIPTION: +-- This test declares a task type that contains discriminants. +-- Objects of the task type are created with different values. +-- The task type has nested tasks that are used to check that +-- the discriminate values are the expected values. +-- Note that the names of the discriminants in the body of task +-- type DTT denote the current instance of the unit. +-- +-- +-- CHANGE HISTORY: +-- 12 OCT 95 SAIC Initial release for 2.1 +-- 8 MAY 96 SAIC Incorporated Reviewer comments. +-- +--! + + +with Report; +procedure C910002 is + Verbose : constant Boolean := False; +begin + Report.Test ("C910002", + "Check that selected_component notation can be" & + " used to access task discriminants"); + declare + + task type DTT + (IA, IB : Integer; + CA, CB : Character) is + entry Check_Values (First_Int : Integer; + First_Char : Character); + end DTT; + + task body DTT is + Int1 : Integer; + Char1 : Character; + + -- simple nested task to check the character values + task Check_Chars is + entry Start_Check; + end Check_Chars; + task body Check_Chars is + begin + accept Start_Check; + if DTT.CA /= Char1 or + DTT.CB /= Character'Succ (Char1) then + Report.Failed ("character check failed. Expected: '" & + Char1 & Character'Succ (Char1) & + "' but found '" & + DTT.CA & DTT.CB & "'"); + elsif Verbose then + Report.Comment ("char check for " & Char1); + end if; + exception + when others => Report.Failed ("exception in Check_Chars"); + end Check_Chars; + + -- use a discriminated task to check the integer values + task type Check_Ints (First : Integer); + task body Check_Ints is + begin + if DTT.IA /= Check_Ints.First or + IB /= First+1 then + Report.Failed ("integer check failed. Expected:" & + Integer'Image (Check_Ints.First) & + Integer'Image (First+1) & + " but found" & + Integer'Image (DTT.IA) & Integer'Image (IB) ); + elsif Verbose then + Report.Comment ("int check for" & Integer'Image (First)); + end if; + exception + when others => Report.Failed ("exception in Check_Ints"); + end Check_Ints; + begin + accept Check_Values (First_Int : Integer; + First_Char : Character) do + Int1 := First_Int; + Char1 := First_Char; + end Check_Values; + + -- kick off the character check + Check_Chars.Start_Check; + + -- do the integer check + declare + Int_Checker : Check_Ints (Int1); + begin + null; -- let task do its thing + end; + + -- do one test here too + if DTT.IA /= Int1 then + Report.Failed ("DTT check failed. Expected:" & + Integer'Image (Int1) & + " but found:" & + Integer'Image (DTT.IA)); + elsif Verbose then + Report.Comment ("DTT check for" & Integer'Image (Int1)); + end if; + exception + when others => Report.Failed ("exception in DTT"); + end DTT; + + T1a : DTT (1, 2, 'a', 'b'); + T9C : DTT (9, 10, 'C', 'D'); + begin -- test encapsulation + T1a.Check_Values (1, 'a'); + T9C.Check_Values (9, 'C'); + end; + + Report.Result; +end C910002; diff --git a/gcc/testsuite/ada/acats/tests/c9/c910003.a b/gcc/testsuite/ada/acats/tests/c9/c910003.a new file mode 100644 index 000000000..b2e11cef8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c910003.a @@ -0,0 +1,185 @@ +-- C910003.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and +-- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the +-- software and documentation contained herein. Unlimited rights are +-- defined in DFAR 252.227-7013(a)(19). By making this public release, +-- the Government intends to confer upon all recipients unlimited rights +-- equal to those held by the Government. These rights include rights to +-- use, duplicate, release or disclose the released technical data and +-- computer software in whole or in part, in any manner and for any purpose +-- whatsoever, and to have or permit others to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that task discriminants that have an access subtype may be +-- dereferenced. +-- +-- Note that discriminants in Ada 83 never can be dereferenced with +-- selection or indexing, as they cannot have an access type. +-- +-- TEST DESCRIPTION: +-- A protected object is defined to create a simple buffer. +-- Two task types are defined, one to put values into the buffer, +-- and one to remove them. The tasks are passed a buffer object as +-- a discriminant with an access subtype. The producer task type includes +-- a discriminant to determine the values to product. The consumer task +-- type includes a value to save the results. +-- Two producer and one consumer tasks are declared, and the results +-- are checked. +-- +-- CHANGE HISTORY: +-- 10 Mar 99 RLB Created test. +-- +--! + +package C910003_Pack is + + type Item_Type is range 1 .. 100; -- In a real application, this probably + -- would be a record type. + + type Item_Array is array (Positive range <>) of Item_Type; + + protected type Buffer is + entry Put (Item : in Item_Type); + entry Get (Item : out Item_Type); + function TC_Items_Buffered return Item_Array; + private + Saved_Item : Item_Type; + Empty : Boolean := True; + TC_Items : Item_Array (1 .. 10); + TC_Last : Natural := 0; + end Buffer; + + type Buffer_Access_Type is access Buffer; + + PRODUCE_COUNT : constant := 2; -- Number of items to produce. + + task type Producer (Buffer_Access : Buffer_Access_Type; + Start_At : Item_Type); + -- Produces PRODUCE_COUNT items. Starts when activated. + + type TC_Item_Array_Access_Type is access Item_Array (1 .. PRODUCE_COUNT*2); + + task type Consumer (Buffer_Access : Buffer_Access_Type; + Results : TC_Item_Array_Access_Type) is + -- Stores PRODUCE_COUNT*2 items consumed in Results. Starts when + -- activated. + entry Wait_until_Done; + end Consumer; + +end C910003_Pack; + + +with Report; +package body C910003_Pack is + + protected body Buffer is + entry Put (Item : in Item_Type) when Empty is + begin + Empty := False; + Saved_Item := Item; + TC_Last := TC_Last + 1; + TC_Items(TC_Last) := Item; + end Put; + + entry Get (Item : out Item_Type) when not Empty is + begin + Empty := True; + Item := Saved_Item; + end Get; + + function TC_Items_Buffered return Item_Array is + begin + return TC_Items(1..TC_Last); + end TC_Items_Buffered; + + end Buffer; + + + task body Producer is + -- Produces PRODUCE_COUNT items. Starts when activated. + begin + for I in 1 .. Report.Ident_Int(PRODUCE_COUNT) loop + Buffer_Access.Put (Start_At + (Item_Type(I)-1)*2); + end loop; + end Producer; + + + task body Consumer is + -- Stores PRODUCE_COUNT*2 items consumed in Results. Starts when + -- activated. + begin + for I in 1 .. Report.Ident_Int(PRODUCE_COUNT*2) loop + Buffer_Access.Get (Results (I)); + -- Buffer_Access and Results are both dereferenced. + end loop; + + -- Check the results (and function call with a prefix dereference). + if Results.all(Report.Ident_Int(1)) /= Buffer_Access.all.TC_Items_Buffered(Report.Ident_Int(1)) then + Report.Failed ("First item mismatch"); + end if; + if Results(Report.Ident_Int(2)) /= Buffer_Access.TC_Items_Buffered(Report.Ident_Int(2)) then + Report.Failed ("Second item mismatch"); + end if; + accept Wait_until_Done; -- Tell main that we're done. + end Consumer; + +end C910003_Pack; + + +with Report; +with C910003_Pack; + +procedure C910003 is + +begin -- C910003 + + Report.Test ("C910003", "Check that tasks discriminants of access types can be dereferenced"); + + + declare -- encapsulate the test + + Buffer_Access : C910003_Pack.Buffer_Access_Type := + new C910003_Pack.Buffer; + + TC_Results : C910003_Pack.TC_Item_Array_Access_Type := + new C910003_Pack.Item_Array (1 .. C910003_Pack.PRODUCE_COUNT*2); + + Producer_1 : C910003_Pack.Producer (Buffer_Access, 12); + Producer_2 : C910003_Pack.Producer (Buffer_Access, 23); + + Consumer : C910003_Pack.Consumer (Buffer_Access, TC_Results); + + use type C910003_Pack.Item_Array; -- For /=. + + begin + Consumer.Wait_until_Done; + if TC_Results.all /= Buffer_Access.TC_Items_Buffered then + Report.Failed ("Different items buffered than returned - Main"); + end if; + if (TC_Results.all /= (12, 14, 23, 25) and + TC_Results.all /= (12, 23, 14, 25) and + TC_Results.all /= (12, 23, 25, 14) and + TC_Results.all /= (23, 12, 14, 25) and + TC_Results.all /= (23, 12, 25, 14) and + TC_Results.all /= (23, 25, 12, 14)) then + -- Above are the only legal results. + Report.Failed ("Wrong results"); + end if; + end; -- encapsulation + + Report.Result; + +end C910003; diff --git a/gcc/testsuite/ada/acats/tests/c9/c91004b.ada b/gcc/testsuite/ada/acats/tests/c9/c91004b.ada new file mode 100644 index 000000000..16a17cf32 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c91004b.ada @@ -0,0 +1,108 @@ +-- C91004B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT A TASK (TYPE) IDENTIFIER, WHEN USED WITHIN ITS OWN +-- BODY, REFERS TO THE EXECUTING TASK. + +-- TEST USING IDENTIFIER IN ABORT STATEMENT, AS AN EXPRESSION IN +-- A MEMBERSHIP TEST, AND THE PREFIX OF 'CALLABLE AND +-- 'TERMINATED. + +-- HISTORY: +-- WEI 3/ 4/82 CREATED ORIGINAL TEST. +-- RJW 11/13/87 RENAMED TEST FROM C910BDA.ADA. ADDED CHECKS FOR +-- MEMBERSHIP TEST, AND 'CALLABLE AND 'TERMINATED +-- ATTRIBUTES. + +WITH REPORT; USE REPORT; +PROCEDURE C91004B IS + + TYPE I0 IS RANGE 0..1; + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + TASK TYPE TT1 IS + ENTRY E1 (P1 : IN I0; P2 : ARG); + ENTRY BYE; + END TT1; + + SUBTYPE SUB_TT1 IS TT1; + + OBJ_TT1 : ARRAY (NATURAL RANGE 1..2) OF TT1; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + TASK BODY TT1 IS + BEGIN + IF TT1 NOT IN SUB_TT1 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST"); + END IF; + + IF NOT TT1'CALLABLE THEN + FAILED ("INCORRECT RESULTS FOR 'CALLABLE"); + END IF; + + IF TT1'TERMINATED THEN + FAILED ("INCORRECT RESULTS FOR 'TERMINATED"); + END IF; + + ACCEPT E1 (P1 : IN I0; P2 : ARG) DO + IF P1 = 1 THEN + ABORT TT1; + ACCEPT BYE; -- WILL DEADLOCK IF NOT ABORTED. + END IF; + PSPY_NUMB (ARG (P2)); + END E1; + + END TT1; + +BEGIN + + TEST ("C91004B", "TASK IDENTIFIER IN OWN BODY"); + + BEGIN + OBJ_TT1 (1).E1 (1,1); + FAILED ("NO TASKING_ERROR RAISED"); +-- ABORT DURING RENDEVOUS RAISES TASKING ERROR + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED"); + END; + + OBJ_TT1 (2).E1 (0,2); + + IF SPYNUMB /= 2 THEN + FAILED ("WRONG TASK OBJECT REFERENCED"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + +END C91004B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c91004c.ada b/gcc/testsuite/ada/acats/tests/c9/c91004c.ada new file mode 100644 index 000000000..a07543370 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c91004c.ada @@ -0,0 +1,82 @@ +-- C91004C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TASK (TYPE) IDENTIFIER, WHEN USED WITHIN ITS OWN BODY +-- REFERS TO THE EXECUTING TASK. +-- +-- TEST USING CONDITIONAL ENTRY CALL. + +-- WEI 3/ 4/82 +-- TLB 10/30/87 RENAMED FROM C910BDB.ADA. + +WITH REPORT; + USE REPORT; +PROCEDURE C91004C IS + + TASK TYPE TT1 IS + ENTRY E1; + ENTRY BYE; + END TT1; + + OBJ_TT1 : ARRAY (NATURAL RANGE 1..2) OF TT1; + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + TASK BODY TT1 IS + BEGIN + ACCEPT E1 DO + PSPY_NUMB (1); + END E1; + + SELECT + TT1.E1; + ELSE + PSPY_NUMB (2); + END SELECT; + + ACCEPT BYE; + END TT1; + +BEGIN + + TEST ("C91004C", "TASK IDENTIFIER IN OWN BODY"); + OBJ_TT1 (1).E1; + OBJ_TT1 (1).BYE; + + IF SPYNUMB /=12 THEN + FAILED ("WRONG TASK OBJECT REFERENCED"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + ABORT OBJ_TT1 (2); + + RESULT; + +END C91004C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c91006a.ada b/gcc/testsuite/ada/acats/tests/c9/c91006a.ada new file mode 100644 index 000000000..1217d1459 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c91006a.ada @@ -0,0 +1,82 @@ +-- C91006A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IN A TASK SPECIFICATION ENTRY DECLARATIONS ARE ELABORATED +-- WHEN THE SPECIFICATION IS ELABORATED, AND IN TEXTUAL ORDER. + +-- WEI 3/04/82 +-- BHS 7/13/84 +-- TBN 12/17/85 RENAMED FROM C910AHA-B.ADA; +-- ADDED DECLARATIONS OF FIRST AND LAST. +-- PWB 5/15/86 MOVED DECLARATIONS OF FIRST, TASK T1, AND LAST +-- INTO A DECLARE/BEGIN/END BLOCK. + +WITH REPORT; USE REPORT; +PROCEDURE C91006A IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + INDEX : INTEGER RANGE 0..5 := 0; + SPYNUMB : STRING(1..5) := (1..5 => ' '); + + FUNCTION FINIT_POS (DIGT: IN ARG) RETURN NATURAL IS + TEMP : STRING(1..2); + BEGIN + TEMP := ARG'IMAGE(DIGT); + INDEX := INDEX + 1; + SPYNUMB(INDEX) := TEMP(2); + RETURN DIGT; + END FINIT_POS; + +BEGIN + TEST ("C91006A", "CHECK THAT IN A TASK SPEC, ELABORATION IS IN " & + "TEXTUAL ORDER"); + DECLARE + + FIRST : INTEGER := FINIT_POS (1); + + TASK T1 IS + ENTRY E2 (NATURAL RANGE 1 .. FINIT_POS (2)); + ENTRY E3 (NATURAL RANGE 1 .. FINIT_POS (3)); + ENTRY E4 (NATURAL RANGE 1 .. FINIT_POS (4)); + END T1; + + LAST : INTEGER := FINIT_POS (5); + + TASK BODY T1 IS + BEGIN + NULL; + END T1; + + BEGIN + NULL; + END; + + IF SPYNUMB /= "12345" THEN + FAILED ("TASK SPEC T1 NOT ELABORATED IN TEXTUAL ORDER"); + COMMENT ("ACTUAL ORDER WAS: " & SPYNUMB); + END IF; + + RESULT; + +END C91006A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c91007a.ada b/gcc/testsuite/ada/acats/tests/c9/c91007a.ada new file mode 100644 index 000000000..d2b21b302 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c91007a.ada @@ -0,0 +1,97 @@ +-- C91007A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- IF THE ELABORATION OF AN ENTRY DECLARATION RAISES +-- "CONSTRAINT_ERROR", THEN NO TASKS ARE ACTIVATED, AND +-- "TASKING_ERROR" IS NOT RAISED. + +-- HISTORY: +-- LDC 06/17/88 CREATED ORGINAL TEST + +WITH REPORT; +USE REPORT; + +PROCEDURE C91007A IS + + TYPE ENUM IS (TERESA, BRIAN, PHIL, JOLEEN, LYNN, DOUG, JODIE, + VINCE, TOM, DAVE, JOHN, ROSA); + SUBTYPE ENUM_SUB IS ENUM RANGE BRIAN..LYNN; + +BEGIN + TEST("C91007A","IF THE ELABORATION OF AN ENTRY DECLARATION " & + "RAISES 'CONSTRAINT_ERROR', THEN NO TASKS ARE " & + "ACTIVATED, AND 'TASKING_ERROR' IS NOT RAISED"); + + BEGIN + DECLARE + TASK TYPE TSK1; + T1 : TSK1; + TASK BODY TSK1 IS + BEGIN + FAILED("TSK1 WAS ACTIVATED"); + END TSK1; + + + TASK TSK2 IS + ENTRY ENT(ENUM_SUB RANGE TERESA..LYNN); + END TSK2; + + TASK BODY TSK2 IS + BEGIN + FAILED("TASK BODY WAS ACTIVATED"); + END TSK2; + + TASK TSK3; + TASK BODY TSK3 IS + BEGIN + FAILED("TSK3 WAS ACTIVATED"); + END TSK3; + + BEGIN + NULL; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR WAS RAISED IN THE " & + "BEGIN BLOCK"); + WHEN TASKING_ERROR => + FAILED("TASKING_ERROR WAS RAISED INSTEAD OF " & + "CONSTRAINT_ERROR IN THE BEGIN BLOCK"); + WHEN OTHERS => + FAILED("OTHER EXCEPTION WAS RAISED IN " & + "THE BEGIN BLOCK"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN TASKING_ERROR => + FAILED("TASKING_ERROR WAS RAISED INSTEAD OF " & + "CONSTRAINT_ERROR"); + WHEN OTHERS => + FAILED("WRONG EXCEPTION WAS RAISED"); + END; + + RESULT; + +END C91007A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c92002a.ada b/gcc/testsuite/ada/acats/tests/c9/c92002a.ada new file mode 100644 index 000000000..879cf36b9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c92002a.ada @@ -0,0 +1,73 @@ +-- C92002A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT ASSIGNMENT TO A COMPONENT (FOR WHICH ASSIGNMENT IS +-- AVAILABLE) OF A RECORD CONTAINING A TASK IS AVAILABLE. + +-- JRK 9/17/81 +-- JWC 6/28/85 RENAMED TO -AB + +WITH REPORT; USE REPORT; +PROCEDURE C92002A IS + +BEGIN + TEST ("C92002A", "CHECK THAT CAN ASSIGN TO ASSIGNABLE " & + "COMPONENTS OF RECORDS WITH TASK " & + "COMPONENTS"); + + DECLARE + + TASK TYPE TT IS + ENTRY E; + END TT; + + TYPE RT IS + RECORD + I : INTEGER := 0; + T : TT; + J : INTEGER := 0; + END RECORD; + + R : RT; + + TASK BODY TT IS + BEGIN + NULL; + END TT; + + BEGIN + + R.I := IDENT_INT (7); + R.J := IDENT_INT (9); + + IF R.I /= 7 AND R.J /= 9 THEN + FAILED ("WRONG VALUE(S) WHEN ASSIGNING TO " & + "INTEGER COMPONENTS OF RECORDS WITH " & + "TASK COMPONENTS"); + END IF; + + END; + + RESULT; +END C92002A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c92003a.ada b/gcc/testsuite/ada/acats/tests/c9/c92003a.ada new file mode 100644 index 000000000..ff42680b0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c92003a.ada @@ -0,0 +1,117 @@ +-- C92003A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TASK CAN BE PASSED AS AN ACTUAL IN OR IN OUT PARAMETER +-- IN A SUBPROGRAM CALL AND THAT THE ACTUAL AND FORMAL PARAMETERS DENOTE +-- THE SAME TASK OBJECT. + +-- JRK 1/17/81 +-- TBN 12/19/85 ADDED IN OUT PARAMETER CASE. +-- PWB 8/04/86 ADDED CHECK THAT FORMAL AND ACTUAL PARAMETERS DENOTE +-- THE SAME TASK OBJECT. + +WITH REPORT; USE REPORT; + +PROCEDURE C92003A IS + +BEGIN + + TEST ("C92003A", "CHECK TASKS PASSED AS ACTUAL IN OR IN OUT " & + "PARAMETERS TO SUBPROGRAMS"); + + DECLARE + + TASK TYPE TT IS + ENTRY E (I : INTEGER); + END TT; + + T, S : TT; + + TASK BODY TT IS + SOURCE : INTEGER; + BEGIN + + SELECT + ACCEPT E (I : INTEGER) DO + SOURCE := I; + END E; + OR + TERMINATE; + END SELECT; + + IF SOURCE /= 1 THEN + FAILED ("EXPECTED 1, GOT " & INTEGER'IMAGE(SOURCE)); + END IF; + + SELECT + ACCEPT E (I : INTEGER) DO + SOURCE := I; + END E; + OR + TERMINATE; + END SELECT; + + IF SOURCE /= 2 THEN + FAILED ("EXPECTED 2, GOT " & INTEGER'IMAGE(SOURCE)); + END IF; + + SELECT + ACCEPT E (I : INTEGER) DO + SOURCE := I; + END E; + OR + TERMINATE; + END SELECT; + + IF SOURCE /= 3 THEN + FAILED ("EXPECTED 3, GOT " & INTEGER'IMAGE(SOURCE)); + END IF; + + END TT; + + PROCEDURE P (T : TT) IS + BEGIN + T.E(2); + END P; + + PROCEDURE Q (S : IN OUT TT) IS + BEGIN + S.E(2); + END Q; + + BEGIN + + T.E(1); -- FIRST CALL TO T.E + P(T); -- SECOND CALL TO T.E + T.E(3); -- THIRD CALL TO T.E + + S.E(1); -- FIRST CALL TO S.E + Q(S); -- SECOND CALL TO S.E + S.E(3); -- THIRD CALL TO S.E + + END; + + RESULT; + +END C92003A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c92005a.ada b/gcc/testsuite/ada/acats/tests/c9/c92005a.ada new file mode 100644 index 000000000..6766c573e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c92005a.ada @@ -0,0 +1,75 @@ +-- C92005A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT FOR A NON-SINGLE TASK THE OBJECT VALUE IS SET DURING +-- ELABORATION OF THE CORRESPONDING OBJECT DECLARATION. + +-- WEI 3/ 4/82 +-- JBG 5/25/85 +-- PWB 2/3/86 CORRECTED TEST ERROR; ADDED 'USE' CLAUSE TO MAKE "/=" +-- FOR BIG_INT VISIBLE. + +WITH REPORT, SYSTEM; + USE REPORT; +PROCEDURE C92005A IS +BEGIN + + TEST ("C92005A", "TASK OBJECT VALUE DURING ELABORATION"); + + DECLARE + TASK TYPE TT1; + + OBJ_TT1 : TT1; + + PACKAGE PACK IS + TYPE BIG_INT IS RANGE 0 .. SYSTEM.MAX_INT; + I : BIG_INT; + END PACK; + + PACKAGE BODY PACK IS + BEGIN + I := OBJ_TT1'STORAGE_SIZE; -- O.K. + EXCEPTION + WHEN OTHERS => + FAILED ("TASK OBJECT RAISED EXCEPTION"); + END PACK; + + USE PACK; + + TASK BODY TT1 IS + BEGIN + NULL; + END TT1; + + BEGIN + IF PACK.I /= OBJ_TT1'STORAGE_SIZE THEN + COMMENT ("STORAGE SIZE CHANGED AFTER TASK ACTIVATED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY STORAGE_SIZE"); + END; + + RESULT; +END C92005A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c92005b.ada b/gcc/testsuite/ada/acats/tests/c9/c92005b.ada new file mode 100644 index 000000000..e5672a7c7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c92005b.ada @@ -0,0 +1,72 @@ +-- C92005B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT FOR A TASK OBJECT CREATED BY AN ALLOCATOR THE +-- OBJECT VALUE IS SET DURING EXECUTION OF THE ALLOCATOR. + +-- WEI 3/ 4/82 +-- JBG 5/25/85 +-- RLB 1/ 7/05 + +WITH REPORT; + USE REPORT; +WITH SYSTEM; +PROCEDURE C92005B IS + TYPE BIG_INT IS RANGE 0..SYSTEM.MAX_INT; +BEGIN + TEST ("C92005B", "TASK VALUE SET BY EXECUTION OF ALLOCATOR"); + +BLOCK: + DECLARE + TASK TYPE TT1; + + TYPE ATT1 IS ACCESS TT1; + + TASK BODY TT1 IS + BEGIN + NULL; + END TT1; + + PACKAGE PACK IS + END PACK; + + PACKAGE BODY PACK IS + POINTER_TT1 : ATT1 := NEW TT1; + I : BIG_INT := POINTER_TT1.ALL'STORAGE_SIZE; + BEGIN + IF NOT EQUAL(INTEGER(I MOD 1024), INTEGER(I MOD 1024)) THEN + FAILED ("UNEXPECTED PROBLEM"); + END IF; + END PACK; + BEGIN + NULL; + EXCEPTION + WHEN PROGRAM_ERROR | CONSTRAINT_ERROR => + FAILED ("TASK OBJECT VALUE NOT SET DURING " & + "EXECUTION OF ALLOCATOR"); + END BLOCK; + + RESULT; + +END C92005B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c92006a.ada b/gcc/testsuite/ada/acats/tests/c9/c92006a.ada new file mode 100644 index 000000000..f0fd0c8c7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c92006a.ada @@ -0,0 +1,93 @@ +-- C92006A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT TASK OBJECTS CAN BE INTERCHANGED BY ASSIGNMENT OF +-- CORRESPONDING ACCESS TYPE OBJECTS. + +-- WEI 3/ 4/82 +-- JWC 6/28/85 RENAMED FROM C920BIA-B.ADA + +WITH REPORT; + USE REPORT; +PROCEDURE C92006A IS + + TASK TYPE TT1 IS + ENTRY E1; + ENTRY E2; + END TT1; + + TYPE ATT1 IS ACCESS TT1; + POINTER_TT1_1, POINTER_TT1_2 : ATT1; + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + PROCEDURE PROC (P1, P2 : IN OUT ATT1) IS + -- SWAP TASK OBJECTS P1, P2. + SCRATCH : ATT1; + BEGIN + SCRATCH := P1; + P1 := P2; + P2 := SCRATCH; + + P1.E2; -- ENTRY2 SECOND OBJECT. + P2.E1; -- VICE VERSA. + + END PROC; + + TASK BODY TT1 IS + BEGIN + ACCEPT E1 DO + PSPY_NUMB (1); + END E1; + ACCEPT E2 DO + PSPY_NUMB (2); + END E2; + END TT1; + +BEGIN + + TEST ("C92006A", "INTERCHANGING TASK OBJECTS"); + POINTER_TT1_1 := NEW TT1; + POINTER_TT1_2 := NEW TT1; + + POINTER_TT1_2.ALL.E1; + PROC (POINTER_TT1_1, POINTER_TT1_2); + POINTER_TT1_2.E2; -- E2 OF FIRST OBJECT +-- EACH ENTRY OF EACH TASK OBJECT SHOULD HAVE BEEN CALLED. + + IF SPYNUMB /= 1212 THEN + FAILED ("FAILURE TO SWAP TASK OBJECTS " & + "IN PROCEDURE PROC"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + +END C92006A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c930001.a b/gcc/testsuite/ada/acats/tests/c9/c930001.a new file mode 100644 index 000000000..874518990 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c930001.a @@ -0,0 +1,153 @@ +-- C930001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- TEST OBJECTIVE: +-- Check when a dependent task and its master both +-- terminate as a result of a terminate alternative that +-- finalization is performed and that the finalization is +-- performed in the proper order. +-- +-- TEST DESCRIPTION: +-- A controlled type with finalization is used to determine +-- the order in which finalization occurs. The finalization +-- procedure records the identity of the object being +-- finalized. +-- Two tasks, one nested inside the other, both contain +-- objects of the above finalization type. These tasks +-- cooperatively terminate so the termination and finalization +-- order can be noted. +-- +-- +-- CHANGE HISTORY: +-- 08 Jan 96 SAIC ACVC 2.1 +-- 09 May 96 SAIC Addressed Reviewer comments. +-- +--! + + +with Ada.Finalization; +package C930001_0 is + Verbose : constant Boolean := False; + + type Ids is range 0..10; + Finalization_Order : array (Ids) of Ids := (Ids => 0); + Finalization_Cnt : Ids := 0; + + protected Note is + -- serializes concurrent access to Finalization_* above + procedure Done (Id : Ids); + end Note; + + -- Objects of the following type are used to note the order in + -- which finalization occurs. + type Has_Finalization is new Ada.Finalization.Limited_Controlled with + record + Id : Ids; + end record; + procedure Finalize (Object : in out Has_Finalization); +end C930001_0; + + +with Report; +package body C930001_0 is + + protected body Note is + procedure Done (Id : Ids) is + begin + Finalization_Cnt := Finalization_Cnt + 1; + Finalization_Order (Finalization_Cnt) := Id; + end Done; + end Note; + + procedure Finalize (Object : in out Has_Finalization) is + begin + Note.Done (Object.Id); + if Verbose then + Report.Comment ("in Finalize for" & Ids'Image (Object.Id)); + end if; + end Finalize; +end C930001_0; + + +with Report; +with ImpDef; +with C930001_0; use C930001_0; +procedure C930001 is +begin + + Report.Test ("C930001", "Check that dependent tasks are terminated" & + " before the remaining finalization"); + + declare + task Level_1; + task body Level_1 is + V1a : C930001_0.Has_Finalization; -------> 4 + task Level_2 is + entry Not_Taken; + end Level_2; + task body Level_2 is + V2 : C930001_0.Has_Finalization; -------> 2 + begin + V2.Id := 2; + C930001_0.Note.Done (1); -------> 1 + select + accept Not_Taken; + or + terminate; + -- cooperative termination at this point of + -- both tasks + end select; + end Level_2; + + -- 7.6.1(11) requires that V1b be finalized before V1a + V1b : C930001_0.Has_Finalization; -------> 3 + begin + V1a.Id := 4; + V1b.Id := 3; + end Level_1; + begin -- declare + while not Level_1'Terminated loop + delay ImpDef.Switch_To_New_Task; + end loop; + C930001_0.Note.Done (5); -------> 5 + + -- now check the order + for I in Ids range 1..5 loop + if Verbose then + Report.Comment (Ids'Image (I) & + Ids'Image (Finalization_Order (I))); + end if; + if Finalization_Order (I) /= I then + Report.Failed ("Finalization occurred out of order" & + " expected:" & + Ids'Image (I) & + " actual:" & + Ids'Image (Finalization_Order (I))); + end if; + end loop; + end; + + Report.Result; +end C930001; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93001a.ada b/gcc/testsuite/ada/acats/tests/c9/c93001a.ada new file mode 100644 index 000000000..3a3b9833b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93001a.ada @@ -0,0 +1,296 @@ +-- C93001A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT DECLARED TASK OBJECTS ARE NOT ACTIVATED BEFORE +-- THE END OF THE DECLARATIVE PART. +-- SUBTESTS ARE: +-- (A) A SIMPLE TASK OBJECT, IN A BLOCK. +-- (B) AN ARRAY OF TASK OBJECT, IN A FUNCTION. +-- (C) A RECORD OF TASK OBJECT, IN A PACKAGE SPECIFICATION. +-- (D) A RECORD OF ARRAY OF TASK OBJECT, IN A PACKAGE BODY. +-- (E) AN ARRAY OF RECORD OF TASK OBJECT, IN A TASK BODY. + +-- THIS TEST ASSUMES THAT ACTIVATION IS A SEQUENTIAL STEP +-- IN THE FLOW OF CONTROL OF THE PARENT (AS IS REQUIRED BY THE +-- ADA RM). IF AN IMPLEMENTATION (ILLEGALLY) ACTIVATES A +-- TASK IN PARALLEL WITH ITS PARENT, THIS TEST +-- IS NOT GUARANTEED TO DETECT THE VIOLATION, DUE TO A +-- RACE CONDITION. + +-- JRK 9/23/81 +-- SPS 11/1/82 +-- SPS 11/21/82 +-- R.WILLIAMS 10/8/86 ADDED CHECKS ON INITIALIZATIONS OF NON-TASK +-- COMPONENTS OF RECORD TYPES. +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93001A IS + + GLOBAL : INTEGER; + + FUNCTION SIDE_EFFECT (I : INTEGER) RETURN INTEGER IS + BEGIN + GLOBAL := IDENT_INT (I); + RETURN 0; + END SIDE_EFFECT; + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + I : INTEGER := SIDE_EFFECT (1); + BEGIN + NULL; + END TT; + + +BEGIN + TEST ("C93001A", "CHECK THAT DECLARED TASK OBJECTS ARE NOT " & + "ACTIVATED BEFORE THE END OF THE DECLARATIVE " & + + "PART"); + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (A) + + T : TT; + I : INTEGER := GLOBAL; + + BEGIN -- (A) + + IF I /= 0 THEN + FAILED ("A SIMPLE TASK OBJECT IN A BLOCK WAS " & + "ACTIVATED TOO SOON - (A)"); + END IF; + + END; -- (A) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (B) + + J : INTEGER; + + FUNCTION F RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + I : INTEGER := GLOBAL; + BEGIN + IF I /= 0 THEN + FAILED ("AN ARRAY OF TASK OBJECT IN A FUNCTION " & + "WAS ACTIVATED TOO SOON - (B)"); + END IF; + RETURN 0; + END F; + + BEGIN -- (B) + + J := F ; + + END; -- (B) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C) + + PACKAGE P IS + + TYPE REC IS + RECORD + T : TT; + N1 : INTEGER := GLOBAL; + END RECORD; + + TYPE RT IS + RECORD + M : INTEGER := GLOBAL; + T : TT; + N : REC; + END RECORD; + R : RT; + I : INTEGER := GLOBAL; + END P; + + PACKAGE Q IS + J : INTEGER; + PRIVATE + TYPE RT IS + RECORD + N : P.REC; + T : TT; + M : INTEGER := GLOBAL; + END RECORD; + R : RT; + END Q; + + K : INTEGER := GLOBAL; + + PACKAGE BODY Q IS + BEGIN + IF R.M /= 0 OR R.N.N1 /= 0 THEN + FAILED ( "NON-TASK COMPONENTS OF RECORD R NOT " & + "INITIALIZED BEFORE TASKS ACTIVATED " & + "- (C.1)" ); + END IF; + END Q; + + BEGIN -- (C) + + IF P.R.M /= 0 OR P.R.N.N1 /= 0 THEN + FAILED ( "NON-TASK COMPONENTS OF RECORDS NOT " & + "INITIALIZED BEFORE TASKS ACTIVATED " & + "- (C.2)" ); + END IF; + + IF P.I /= 0 OR K /= 0 THEN + FAILED ("A RECORD OF TASK OBJECT IN A PACKAGE " & + "SPECIFICATION WAS ACTIVATED TOO SOON - (C)"); + END IF; + + END; -- (C) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (D) + + PACKAGE P IS + + TYPE GRADE IS (GOOD, FAIR, POOR); + + TYPE REC (G : GRADE) IS + RECORD + NULL; + END RECORD; + + TYPE ACCR IS ACCESS REC; + TYPE ACCI IS ACCESS INTEGER; + + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RAT IS + RECORD + M : ACCR := NEW REC (GRADE'VAL (GLOBAL)); + A : ARR; + N : ACCI := NEW INTEGER'(GLOBAL); + END RECORD; + RA1 : RAT; + PRIVATE + RA2 : RAT; + END P; + + PACKAGE BODY P IS + RA3 : RAT; + I : INTEGER := GLOBAL; + BEGIN + IF RA1.M.G /= GOOD OR RA1.N.ALL /= 0 THEN + FAILED ( "NON-TASK COMPONENTS OF RECORD RA1 NOT " & + "INITIALIZED BEFORE TASKS ACTIVATED " & + "- (D)" ); + END IF; + + IF RA2.M.G /= GOOD OR RA2.N.ALL /= 0 THEN + FAILED ( "NON-TASK COMPONENTS OF RECORD RA2 NOT " & + "INITIALIZED BEFORE TASKS ACTIVATED " & + "- (D)" ); + END IF; + + IF RA3.M.G /= GOOD OR RA3.N.ALL /= 0 THEN + FAILED ( "NON-TASK COMPONENTS OF RECORD RA3 NOT " & + "INITIALIZED BEFORE TASKS ACTIVATED " & + "- (D)" ); + END IF; + + IF I /= 0 THEN + FAILED ("A RECORD OF ARRAY OF TASK OBJECT IN A " & + "PACKAGE SPEC OR BODY WAS ACTIVATED " & + "TOO SOON - (D)"); + END IF; + END P; + + BEGIN -- (D) + + NULL; + + END; -- (D) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (E) + + TYPE REC IS + RECORD + B : BOOLEAN := BOOLEAN'VAL (GLOBAL); + T : TT; + C :CHARACTER :=CHARACTER'VAL (GLOBAL); + END RECORD; + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + TYPE RT IS + RECORD + M : REC; + T : TT; + N : REC; + END RECORD; + AR : ARRAY (1..1) OF RT; + I : INTEGER := GLOBAL; + BEGIN + IF AR (1).M.B /= FALSE OR AR (1).M.C /= ASCII.NUL OR + AR (1).N.B /= FALSE OR AR (1).N.C /= ASCII.NUL THEN + FAILED ( "NON-TASK COMPONENTS OF RECORD RT NOT " & + "INITIALIZED BEFORE TASKS ACTIVATED " & + "- (E)" ); + END IF; + + IF I /= 0 THEN + FAILED ("AN ARRAY OF RECORD OF TASK OBJECT IN A " & + "TASK BODY WAS ACTIVATED TOO SOON - (E)"); + END IF; + END T; + + BEGIN -- (E) + + NULL; + + END; -- (E) + + -------------------------------------------------- + + RESULT; +END C93001A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93002a.ada b/gcc/testsuite/ada/acats/tests/c9/c93002a.ada new file mode 100644 index 000000000..a9999ad2a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93002a.ada @@ -0,0 +1,231 @@ +-- C93002A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT DECLARED TASK OBJECTS ARE ACTIVATED BEFORE EXECUTION +-- OF THE FIRST STATEMENT FOLLOWING THE DECLARATIVE PART. +-- SUBTESTS ARE: +-- (A) A SIMPLE TASK OBJECT, IN A BLOCK. +-- (B) AN ARRAY OF TASK OBJECT, IN A FUNCTION. +-- (C) A RECORD OF TASK OBJECT, IN A PACKAGE SPECIFICATION. +-- (D) A RECORD OF ARRAY OF TASK OBJECT, IN A PACKAGE BODY. +-- (E) AN ARRAY OF RECORD OF TASK OBJECT, IN A TASK BODY. + +-- JRK 9/28/81 +-- SPS 11/1/82 +-- SPS 11/21/82 +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93002A IS + + GLOBAL : INTEGER; + + FUNCTION SIDE_EFFECT (I : INTEGER) RETURN INTEGER IS + BEGIN + GLOBAL := IDENT_INT (I); + RETURN 0; + END SIDE_EFFECT; + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + I : INTEGER := SIDE_EFFECT (1); + BEGIN + NULL; + END TT; + + +BEGIN + TEST ("C93002A", "CHECK THAT DECLARED TASK OBJECTS ARE " & + "ACTIVATED BEFORE EXECUTION OF THE FIRST " & + "STATEMENT FOLLOWING THE DECLARATIVE PART"); + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (A) + + T : TT; + + BEGIN -- (A) + + IF GLOBAL /= 1 THEN + FAILED ("A SIMPLE TASK OBJECT IN A BLOCK WAS " & + "ACTIVATED TOO LATE - (A)"); + END IF; + + END; -- (A) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (B) + + J : INTEGER; + + FUNCTION F RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + BEGIN + IF GLOBAL /= 1 THEN + FAILED ("AN ARRAY OF TASK OBJECT IN A FUNCTION " & + "WAS ACTIVATED TOO LATE - (B)"); + END IF; + RETURN 0; + END F; + + BEGIN -- (B) + + J := F ; + + END; -- (B) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C1) + + PACKAGE P IS + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RT IS + RECORD + A : ARR; + END RECORD; + R : RT; + END P; + + PACKAGE BODY P IS + BEGIN + IF GLOBAL /= 1 THEN + FAILED ("A RECORD OF TASK OBJECT IN A PACKAGE " & + "SPECIFICATION WAS ACTIVATED TOO LATE " & + "- (C1)"); + END IF; + END P; + + BEGIN -- (C1) + + NULL; + + END; -- (C1) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C2) + + PACKAGE Q IS + J : INTEGER; + PRIVATE + TYPE RT IS + RECORD + T : TT; + END RECORD; + R : RT; + END Q; + + PACKAGE BODY Q IS + BEGIN + IF GLOBAL /= 1 THEN + FAILED ("A RECORD OF TASK OBJECT IN A PACKAGE " & + "SPECIFICATION WAS ACTIVATED TOO LATE " & + "- (C2)"); + END IF; + END Q; + + BEGIN -- (C2) + + NULL; + + END; -- (C2) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (D) + + PACKAGE P IS + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RAT IS + RECORD + A : ARR; + END RECORD; + END P; + + PACKAGE BODY P IS + RA : RAT; + BEGIN + IF GLOBAL /= 1 THEN + FAILED ("A RECORD OF ARRAY OF TASK OBJECT IN A " & + "PACKAGE BODY WAS ACTIVATED " & + "TOO LATE - (D)"); + END IF; + END P; + + BEGIN -- (D) + + NULL; + + END; -- (D) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (E) + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + TYPE RT IS + RECORD + T : TT; + END RECORD; + AR : ARRAY (1..1) OF RT; + BEGIN + IF GLOBAL /= 1 THEN + FAILED ("AN ARRAY OF RECORD OF TASK OBJECT IN A " & + "TASK BODY WAS ACTIVATED TOO LATE - (E)"); + END IF; + END T; + + BEGIN -- (E) + + NULL; + + END; -- (E) + + -------------------------------------------------- + + RESULT; +END C93002A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93003a.ada b/gcc/testsuite/ada/acats/tests/c9/c93003a.ada new file mode 100644 index 000000000..48dced34e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93003a.ada @@ -0,0 +1,351 @@ +-- C93003A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT ACTIVATION OF TASKS CREATED BY ALLOCATORS PRESENT IN A +-- DECLARATIVE PART TAKES PLACE DURING ELABORATION OF THE +-- CORRESPONDING DECLARATION. +-- SUBTESTS ARE: +-- (A) A SIMPLE TASK ALLOCATOR, IN A BLOCK. +-- (B) AN ARRAY OF TASK ALLOCATOR, IN A FUNCTION. +-- (C) A RECORD OF TASK ALLOCATOR, IN A PACKAGE SPECIFICATION. +-- (D) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A PACKAGE BODY. +-- (E) AN ARRAY OF RECORD OF TASK ALLOCATOR, IN A TASK BODY. + +-- JRK 9/28/81 +-- SPS 11/11/82 +-- SPS 11/21/82 +-- RJW 8/4/86 ADDED CHECKS ON INITIALIZATIONS OF NON-TASK COMPONENTS +-- OF RECORD TYPES. +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93003A IS + + GLOBAL : INTEGER; + + FUNCTION SIDE_EFFECT (I : INTEGER) RETURN INTEGER IS + BEGIN + GLOBAL := IDENT_INT (I); + RETURN 0; + END SIDE_EFFECT; + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + I : INTEGER := SIDE_EFFECT (1); + BEGIN + NULL; + END TT; + + +BEGIN + TEST ("C93003A", "CHECK THAT ACTIVATION OF TASKS CREATED BY " & + "ALLOCATORS PRESENT IN A DECLARATIVE PART " & + "TAKES PLACE DURING ELABORATION OF THE " & + "CORRESPONDING DECLARATION"); + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (A) + + TYPE A IS ACCESS TT; + T1 : A := NEW TT; + I1 : INTEGER := GLOBAL; + J : INTEGER := SIDE_EFFECT (0); + T2 : A := NEW TT; + I2 : INTEGER := GLOBAL; + + BEGIN -- (A) + + IF I1 /= 1 OR I2 /= 1 THEN + FAILED ("A SIMPLE TASK ALLOCATOR IN A BLOCK WAS " & + "ACTIVATED TOO LATE - (A)"); + END IF; + + END; -- (A) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (B) + + J : INTEGER; + + FUNCTION F RETURN INTEGER IS + + TYPE A_T IS ARRAY (1 .. 1) OF TT; + TYPE A IS ACCESS A_T; + A1 : A := NEW A_T; + I1 : INTEGER := GLOBAL; + J : INTEGER := SIDE_EFFECT (0); + A2 : A := NEW A_T; + I2 : INTEGER := GLOBAL; + + BEGIN + IF I1 /= 1 OR I2 /= 1 THEN + FAILED ("AN ARRAY OF TASK ALLOCATOR IN A " & + "FUNCTION WAS ACTIVATED TOO LATE - (B)"); + END IF; + RETURN 0; + END F; + + BEGIN -- (B) + + J := F ; + + END; -- (B) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C1) + + PACKAGE P IS + + TYPE INTREC IS + RECORD + N1 : INTEGER := GLOBAL; + END RECORD; + + TYPE RT IS + RECORD + M : INTEGER := GLOBAL; + T : TT; + N : INTREC; + END RECORD; + + TYPE A IS ACCESS RT; + + R1 : A := NEW RT; + I1 : INTEGER := GLOBAL; + J : INTEGER := SIDE_EFFECT (0); + R2 : A := NEW RT; + I2 : INTEGER := GLOBAL; + + END P; + + BEGIN -- (C1) + + IF P.R1.M /= 0 OR P.R1.N.N1 /= 0 THEN + FAILED ("NON-TASK COMPONENTS OF RECORD R1 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED - (C1)" ); + END IF; + + IF P.R2.M /= 0 OR P.R2.N.N1 /= 0 THEN + FAILED ("NON-TASK COMPONENTS OF RECORD R2 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED - (C1)" ); + END IF; + + IF P.I1 /= 1 OR P.I2 /= 1 THEN + FAILED ("A RECORD OF TASK ALLOCATOR IN A PACKAGE " & + "SPECIFICATION WAS ACTIVATED TOO LATE - (C1)"); + END IF; + + END; -- (C1) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C2) + + PACKAGE Q IS + J1 : INTEGER; + PRIVATE + + TYPE GRADE IS (GOOD, FAIR, POOR); + + TYPE REC (G : GRADE) IS + RECORD + NULL; + END RECORD; + + TYPE ACCR IS ACCESS REC; + + TYPE ACCI IS ACCESS INTEGER; + + TYPE RT IS + RECORD + M : ACCR := NEW REC (GRADE'VAL (GLOBAL)); + T : TT; + N : ACCI := NEW INTEGER'(GLOBAL); + END RECORD; + + TYPE A IS ACCESS RT; + + R1 : A := NEW RT; + I1 : INTEGER := GLOBAL; + J2 : INTEGER := SIDE_EFFECT (0); + R2 : A := NEW RT; + I2 : INTEGER := GLOBAL; + + END Q; + + PACKAGE BODY Q IS + BEGIN + IF R1.M.G /= GOOD OR R1.N.ALL /= 0 THEN + FAILED ("NON-TASK COMPONENTS OF RECORD R1 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED " & + "- (C2)" ); + END IF; + + IF R2.M.G /= GOOD OR R2.N.ALL /= 0 THEN + FAILED ("NON-TASK COMPONENTS OF RECORD R2 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED " & + "- (C2)" ); + END IF; + + IF I1 /= 1 OR I2 /= 1 THEN + FAILED ("A RECORD OF TASK ALLOCATOR IN A PACKAGE " & + "SPECIFICATION WAS ACTIVATED TOO LATE " & + "- (C2)"); + END IF; + END Q; + + BEGIN -- (C2) + + NULL; + + END; -- (C2) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (D) + + PACKAGE P IS + + TYPE ARR IS ARRAY (1 .. 1) OF TT; + TYPE INTARR IS ARRAY (1 .. 1) OF INTEGER; + + TYPE RAT IS + RECORD + M : INTARR := (1 => GLOBAL); + A : ARR; + N : INTARR := (1 => GLOBAL); + END RECORD; + END P; + + PACKAGE BODY P IS + + TYPE A IS ACCESS RAT; + + RA1 : A := NEW RAT; + I1 : INTEGER := GLOBAL; + J : INTEGER := SIDE_EFFECT (0); + RA2 : A := NEW RAT; + I2 : INTEGER := GLOBAL; + + BEGIN + IF RA1.M (1) /= 0 OR RA1.N (1) /= 0 THEN + FAILED ("NON-TASK COMPONENTS OF RECORD RA1 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED " & + "- (D)" ); + END IF; + + IF RA2.M (1) /= 0 OR RA2.N (1) /= 0 THEN + FAILED ("NON-TASK COMPONENTS OF RECORD RA2 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED " & + "- (D)" ); + END IF; + + IF I1 /= 1 OR I2 /= 1 THEN + FAILED ("A RECORD OF ARRAY OF TASK ALLOCATOR IN " & + "A PACKAGE BODY WAS ACTIVATED " & + "TOO LATE - (D)"); + END IF; + END P; + + BEGIN -- (D) + + NULL; + + END; -- (D) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (E) + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + TYPE RT IS + RECORD + M : BOOLEAN := BOOLEAN'VAL (GLOBAL); + T : TT; + N : CHARACTER := CHARACTER'VAL (GLOBAL); + END RECORD; + + TYPE ART IS ARRAY (1 .. 1) OF RT; + TYPE A IS ACCESS ART; + + AR1 : A := NEW ART; + I1 : INTEGER := GLOBAL; + J : INTEGER := SIDE_EFFECT (0); + AR2 : A := NEW ART; + I2 : INTEGER := GLOBAL; + + BEGIN + IF AR1.ALL (1).M /= FALSE OR + AR1.ALL (1).N /= ASCII.NUL THEN + FAILED ("NON-TASK COMPONENTS OF RECORD AR1 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED " & + "- (E)" ); + END IF; + + IF AR2.ALL (1).M /= FALSE OR + AR2.ALL (1).N /= ASCII.NUL THEN + FAILED ("NON-TASK COMPONENTS OF RECORD AR2 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED " & + "- (E)" ); + END IF; + + IF I1 /= 1 OR I2 /= 1 THEN + FAILED ("AN ARRAY OF RECORD OF TASK ALLOCATOR IN " & + "A TASK BODY WAS ACTIVATED TOO LATE - (E)"); + END IF; + END T; + + BEGIN -- (E) + + NULL; + + END; -- (E) + + -------------------------------------------------- + + RESULT; +END C93003A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93004a.ada b/gcc/testsuite/ada/acats/tests/c9/c93004a.ada new file mode 100644 index 000000000..688bec139 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93004a.ada @@ -0,0 +1,67 @@ +-- C93004A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TASK BECOMES COMPLETED WHEN AN EXCEPTION OCCURS DURING +-- ITS ACTIVATION. + +-- WEI 3/ 4/82 + +WITH REPORT; + USE REPORT; +PROCEDURE C93004A IS +BEGIN + + TEST ("C93004A", "TASK COMPLETION CAUSED BY EXCEPTION"); + +BLOCK: + DECLARE + TYPE I0 IS RANGE 0..1; + + TASK T1 IS + ENTRY BYE; + END T1; + + TASK BODY T1 IS + SUBTYPE I1 IS I0 RANGE 0 .. 2; -- CONSTRAINT ERROR. + BEGIN + ACCEPT BYE; + END T1; + BEGIN + FAILED ("NO EXCEPTION RAISED"); + IF NOT T1'TERMINATED THEN + FAILED ("TASK NOT TERMINATED"); + T1.BYE; + END IF; + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED"); + END BLOCK; + + RESULT; + +END C93004A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93004b.ada b/gcc/testsuite/ada/acats/tests/c9/c93004b.ada new file mode 100644 index 000000000..0b140f59c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93004b.ada @@ -0,0 +1,132 @@ +-- C93004B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT WHEN AN EXCEPTION IS RAISED DURING THE ACTIVATION OF A +-- TASK, OTHER TASKS ARE UNAFFECTED. + +-- THE ENCLOSING BLOCK RECEIVES TASKING_ERROR. + +-- CHECK THAT TASKS WAITING ON ENTRIES OF SUCH TASKS RECEIVE +-- TASKING_ERROR + +-- JEAN-PIERRE ROSEN 09-MAR-1984 +-- JBG 06/01/84 +-- JBG 05/23/85 +-- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93004B IS + +BEGIN + TEST("C93004B", "EXCEPTIONS DURING ACTIVATION"); + + DECLARE + + TASK TYPE T1 IS + END T1; + + TASK TYPE T2 IS + ENTRY E; + END T2; + + ARR_T2: ARRAY(INTEGER RANGE 1..1) OF T2; + + TYPE AT1 IS ACCESS T1; + + PACKAGE START_T1 IS -- THIS PACKAGE TO AVOID ACCESS BEFORE + END START_T1; -- ELABORATION ON T1. + + TASK BODY T1 IS + BEGIN + DECLARE -- THIS BLOCK TO CHECK THAT T1BIS TERMINATES. + TASK T1BIS IS + END T1BIS; + + TASK BODY T1BIS IS + BEGIN + ARR_T2(IDENT_INT(1)).E; + FAILED ("RENDEZVOUS COMPLETED - T1BIS"); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T1BIS"); + END T1BIS; + BEGIN + NULL; + END; + + ARR_T2(IDENT_INT(1)).E; -- ARR_T2(1) IS NOW TERMINATED. + + FAILED ("RENDEZVOUS COMPLETED WITHOUT ERROR - T1"); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T1"); + END; + + PACKAGE BODY START_T1 IS + V_AT1 : AT1 := NEW T1; + END START_T1; + + TASK BODY T2 IS + I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR. + BEGIN + IF I /= IDENT_INT(2) OR I = IDENT_INT(1) + 1 THEN + FAILED("T2 ACTIVATED OK"); + END IF; + END T2; + + TASK T3 IS + ENTRY E; + END T3; + + TASK BODY T3 IS + BEGIN -- T3 MUST BE ACTIVATED OK. + ACCEPT E; + END T3; + + BEGIN + FAILED ("TASKING_ERROR NOT RAISED IN MAIN"); + T3.E; -- CLEAN UP. + EXCEPTION + WHEN TASKING_ERROR => + BEGIN + T3.E; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("T3 NOT ACTIVATED"); + END; + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED IN MAIN"); + WHEN OTHERS => + FAILED ("ABNORMAL EXCEPTION IN MAIN-2"); + END; + + RESULT; +END C93004B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93004c.ada b/gcc/testsuite/ada/acats/tests/c9/c93004c.ada new file mode 100644 index 000000000..bb4d68b5b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93004c.ada @@ -0,0 +1,136 @@ +-- C93004C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT WHEN AN EXCEPTION IS RAISED DURING THE ACTIVATION OF A +-- TASK, OTHER TASKS ARE UNAFFECTED. + +-- IF SEVERAL TASKS FAIL THEIR ACTIVATION, ONLY ONE TASKING_ERROR IS +-- RAISED. + +-- THE ENCLOSING BLOCK RECEIVES TASKING_ERROR. + +-- CHECK THAT TASKS WAITING ON ENTRIES OF SUCH TASKS RECEIVE +-- TASKING_ERROR + +-- JEAN-PIERRE ROSEN 09-MAR-1984 +-- JBG 06/01/84 +-- JBG 05/23/85 +-- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93004C IS + +BEGIN + TEST("C93004C", "EXCEPTIONS DURING ACTIVATION"); + + DECLARE + + TASK TYPE T1 IS + END T1; + + TASK TYPE T2 IS + ENTRY E; + END T2; + + ARR_T2: ARRAY(INTEGER RANGE 1..4) OF T2; + + TYPE AT1 IS ACCESS T1; + + PACKAGE START_T1 IS -- THIS PACKAGE TO AVOID ACCESS + END START_T1; -- BEFORE ELABORATION ON T1. + + TASK BODY T1 IS + BEGIN + DECLARE -- THIS BLOCK TO CHECK THAT T1BIS TERMINATES. + TASK T1BIS IS + END T1BIS; + + TASK BODY T1BIS IS + BEGIN + ARR_T2(IDENT_INT(2)).E; + FAILED ("RENDEZVOUS COMPLETED - T3"); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T3"); + END T1BIS; + BEGIN + NULL; + END; + + ARR_T2(IDENT_INT(2)).E; -- ARR_T2(2) IS NOW TERMINATED. + + FAILED ("RENDEZVOUS COMPLETED WITHOUT ERROR - T1"); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T1"); + END; + + PACKAGE BODY START_T1 IS + V_AT1 : AT1 := NEW T1; + END START_T1; + + TASK BODY T2 IS + I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR. + BEGIN + IF I /= IDENT_INT(2) OR I = IDENT_INT(1) + 1 THEN + FAILED("T2 ACTIVATED OK"); + END IF; + END T2; + + TASK T3 IS + ENTRY E; + END T3; + + TASK BODY T3 IS + BEGIN -- T3 MUST BE ACTIVATED OK. + ACCEPT E; + END T3; + + BEGIN + FAILED ("TASKING_ERROR NOT RAISED IN MAIN"); + T3.E; -- CLEAN UP. + EXCEPTION + WHEN TASKING_ERROR => + BEGIN + T3.E; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("T3 NOT ACTIVATED"); + END; + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED IN MAIN"); + WHEN OTHERS => + FAILED ("ABNORMAL EXCEPTION IN MAIN-2"); + END; + + RESULT; + +END C93004C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93004d.ada b/gcc/testsuite/ada/acats/tests/c9/c93004d.ada new file mode 100644 index 000000000..40eb01fba --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93004d.ada @@ -0,0 +1,152 @@ +-- C93004D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT WHEN AN EXCEPTION IS RAISED DURING THE ACTIVATION OF A +-- TASK, OTHER TASKS ARE UNAFFECTED. + +-- THIS TEST CHECKS THE CASE IN WHICH SOME OF THE OTHER TASKS ARE +-- PERHAPS ACTIVATED BEFORE THE EXCEPTION OCCURS AND SOME TASKS ARE +-- PERHAPS ACTIVATED AFTER. + +-- THE ENCLOSING BLOCK RECEIVES TASKING_ERROR. + +-- CHECK THAT TASKS WAITING FOR ENTRIES OF SUCH TASKS RECEIVE +-- TASKING_ERROR. + +-- R. WILLIAMS 8/6/86 +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE C93004D IS + + +BEGIN + TEST ( "C93004D", "CHECK THAT WHEN AN EXCEPTION IS RAISED " & + "DURING ACTIVATION OF A TASK, OTHER TASKS " & + "ARE NOT AFFECTED. IN THIS TEST, SOME OF THE " & + "TASKS ARE PERHAPS ACTIVATED BEFORE THE " & + "EXCEPTION OCCURS AND SOME PERHAPS AFTER" ); + + + DECLARE + + TASK T0 IS + ENTRY E; + END T0; + + TASK TYPE T1 IS + END T1; + + TASK TYPE T2 IS + ENTRY E; + END T2; + + ARR_T2: ARRAY(INTEGER RANGE 1..4) OF T2; + + TYPE AT1 IS ACCESS T1; + + TASK BODY T0 IS + BEGIN + ACCEPT E; + END T0; + + PACKAGE START_T1 IS -- THIS PACKAGE TO AVOID ACCESS + END START_T1; -- BEFORE ELABORATION ON T1. + + TASK BODY T1 IS + BEGIN + DECLARE -- THIS BLOCK TO CHECK THAT T1BIS TERMINATES. + TASK T1BIS IS + END T1BIS; + + TASK BODY T1BIS IS + BEGIN + ARR_T2(IDENT_INT(2)).E; + FAILED ("RENDEZVOUS COMPLETED - T3"); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T3"); + END T1BIS; + BEGIN + NULL; + END; + + ARR_T2(IDENT_INT(2)).E; -- ARR_T2(2) IS NOW + -- TERMINATED. + + FAILED ("RENDEZVOUS COMPLETED WITHOUT ERROR - T1"); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T1"); + END; + + PACKAGE BODY START_T1 IS + V_AT1 : AT1 := NEW T1; + END START_T1; + + TASK BODY T2 IS + I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR. + BEGIN + IF I /= IDENT_INT(2) OR I = IDENT_INT(1) + 1 THEN + FAILED("T2 ACTIVATED OK"); + END IF; + END T2; + + TASK T3 IS + ENTRY E; + END T3; + + TASK BODY T3 IS + BEGIN -- T3 MUST BE ACTIVATED OK. + ACCEPT E; + END T3; + + BEGIN -- T0, ARR_T2 (1 .. 4), T3 ACTIVATED HERE. + + FAILED ("TASKING_ERROR NOT RAISED IN MAIN"); + T3.E; -- CLEAN UP. + T0.E; + EXCEPTION + WHEN TASKING_ERROR => + BEGIN + T3.E; + T0.E; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("T0 OR T3 NOT ACTIVATED"); + END; + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED IN MAIN"); + WHEN OTHERS => + FAILED ("ABNORMAL EXCEPTION IN MAIN-2"); + END; + + RESULT; +END C93004D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93004f.ada b/gcc/testsuite/ada/acats/tests/c9/c93004f.ada new file mode 100644 index 000000000..9267d3ec8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93004f.ada @@ -0,0 +1,130 @@ +-- C93004F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT WHEN AN EXCEPTION IS RAISED DURING THE ACTIVATION OF A +-- TASK, OTHER TASKS ARE UNAFFECTED. + +-- THE ENCLOSING BLOCK RECEIVES TASKING_ERROR. + +-- THIS TESTS CHECKS THE CASE IN WHICH THE TASKS ARE CREATED BY THE +-- ALLOCATION OF A RECORD OF TASKS OR AN ARRAY OF TASKS. + +-- R. WILLIAMS 8/7/86 + +WITH REPORT; USE REPORT; + +PROCEDURE C93004F IS + +BEGIN + TEST ( "C93004F", "CHECK THAT WHEN AN EXCEPTION IS RAISED " & + "DURING THE ACTIVATION OF A TASK, OTHER " & + "TASKS ARE UNAFFECTED. IN THIS TEST, THE " & + "TASKS ARE CREATED BY THE ALLOCATION OF A " & + "RECORD OR AN ARRAY OF TASKS" ); + + DECLARE + + TASK TYPE T IS + ENTRY E; + END T; + + TASK TYPE TT; + + TASK TYPE TX IS + ENTRY E; + END TX; + + TYPE REC IS + RECORD + TR : T; + END RECORD; + + TYPE ARR IS ARRAY (IDENT_INT (1) .. IDENT_INT (1)) OF T; + + TYPE RECX IS + RECORD + TTX1 : TX; + TTT : TT; + TTX2 : TX; + END RECORD; + + TYPE ACCR IS ACCESS REC; + AR : ACCR; + + TYPE ACCA IS ACCESS ARR; + AA : ACCA; + + TYPE ACCX IS ACCESS RECX; + AX : ACCX; + + TASK BODY T IS + BEGIN + ACCEPT E; + END T; + + TASK BODY TT IS + BEGIN + AR.TR.E; + EXCEPTION + WHEN OTHERS => + FAILED ( "TASK AR.TR NOT ACTIVE" ); + END TT; + + TASK BODY TX IS + I : POSITIVE := IDENT_INT (0); -- RAISE + -- CONSTRAINT_ERROR. + BEGIN + IF I /= IDENT_INT (2) OR I = IDENT_INT (1) + 1 THEN + FAILED ( "TX ACTIVATED OK" ); + END IF; + END TX; + + BEGIN + AR := NEW REC; + AA := NEW ARR; + AX := NEW RECX; + + FAILED ( "TASKING_ERROR NOT RAISED IN MAIN" ); + + AA.ALL (1).E; -- CLEAN UP. + + EXCEPTION + WHEN TASKING_ERROR => + + BEGIN + AA.ALL (1).E; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ( "AA.ALL (1) NOT ACTIVATED" ); + END; + + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED IN MAIN" ); + WHEN OTHERS => + FAILED ( "ABNORMAL EXCEPTION IN MAIN" ); + END; + + RESULT; + +END C93004F; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005a.ada b/gcc/testsuite/ada/acats/tests/c9/c93005a.ada new file mode 100644 index 000000000..95626f688 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93005a.ada @@ -0,0 +1,130 @@ +-- C93005A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT WHEN AN EXCEPTION IS RAISED IN A DECLARATIVE PART, A TASK +-- DECLARED IN THE SAME DECLARATIVE PART BECOMES TERMINATED. + +-- CHECK THAT A TASK WAITING ON ENTRIES OF SUCH A +-- TERMINATED-BEFORE-ACTIVATION TASK RECEIVES TASKING_ERROR. + +-- JEAN-PIERRE ROSEN 3/9/84 +-- JBG 06/01/84 +-- JBG 05/23/85 +-- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. +-- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93005A IS + +BEGIN + TEST("C93005A", "EXCEPTIONS RAISED IN A DECLARATIVE PART " & + "CONTAINING TASKS"); + + BEGIN + + DECLARE + TASK TYPE T1 IS -- CHECKS THAT T2 TERMINATES. + END T1; + + TYPE AT1 IS ACCESS T1; + + TASK T2 IS -- WILL NEVER BE ACTIVATED. + ENTRY E; + END T2; + + PACKAGE RAISE_IT IS + END RAISE_IT; + + TASK BODY T2 IS + BEGIN + FAILED ("T2 ACTIVATED"); + -- IN CASE OF FAILURE + LOOP + SELECT + ACCEPT E; + OR + TERMINATE; + END SELECT; + END LOOP; + END T2; + + TASK BODY T1 IS + BEGIN + DECLARE -- THIS BLOCK TO CHECK THAT T3 TERMINATES. + TASK T3 IS + END T3; + + TASK BODY T3 IS + BEGIN + T2.E; + FAILED ("RENDEZVOUS COMPLETED WITHOUT " & + "ERROR - T3"); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T3"); + END T3; + BEGIN + NULL; + END; + + T2.E; --T2 IS NOW TERMINATED + + FAILED ("RENDEZVOUS COMPLETED WITHOUT ERROR - T1"); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T1"); + END; + + PACKAGE BODY RAISE_IT IS + PT1 : AT1 := NEW T1; + I : POSITIVE := IDENT_INT(0); -- RAISE + -- CONSTRAINT_ERROR. + BEGIN + IF I /= IDENT_INT(2) OR I = IDENT_INT(1) + 1 THEN + FAILED ("PACKAGE DIDN'T RAISE EXCEPTION"); + END IF; + END RAISE_IT; + + BEGIN -- CAN'T LEAVE BLOCK UNTIL T1, T2, AND T3 ARE TERM. + FAILED ("EXCEPTION NOT RAISED"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR IN MAIN PROGRAM"); + WHEN OTHERS => + FAILED ("ABNORMAL EXCEPTION IN MAIN-1"); + END; + + RESULT; + +END C93005A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005b.ada b/gcc/testsuite/ada/acats/tests/c9/c93005b.ada new file mode 100644 index 000000000..1b621c0de --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93005b.ada @@ -0,0 +1,273 @@ +-- C93005B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT WHEN AN EXCEPTION IS RAISED IN A DECLARATIVE PART, A TASK +-- DECLARED IN THE SAME DECLARATIVE PART BECOMES TERMINATED. + +-- CHECK THAT A TASK WAITING ON ENTRIES OF SUCH A +-- TERMINATED-BEFORE-ACTIVATION TASK RECEIVES TASKING_ERROR. + +-- THIS TEST CHECKS THE CASE IN WHICH SEVERAL TASKS ARE WAITING FOR +-- ACTIVATION WHEN THE EXCEPTION OCCURS. + +-- R. WILLIAMS 8/7/86 +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; + +PROCEDURE C93005B IS + + +BEGIN + TEST ( "C93005B", "CHECK THAT WHEN AN EXCEPTION IS RAISED IN A " & + "DECLARATIVE PART, A TASK DECLARED IN THE " & + "SAME DECLARATIVE PART BECOMES TERMINATED. " & + "IN THIS CASE, SEVERAL TASKS ARE WAITING FOR " & + "ACTIVATION WHEN THE EXCEPTION OCCURS" ); + + BEGIN + + DECLARE + TASK TYPE TA IS -- CHECKS THAT TX TERMINATES. + END TA; + + TYPE ATA IS ACCESS TA; + + TASK TYPE TB IS -- CHECKS THAT TY TERMINATES. + END TB; + + TYPE TBREC IS + RECORD + TTB: TB; + END RECORD; + + TASK TX IS -- WILL NEVER BE ACTIVATED. + ENTRY E; + END TX; + + TASK BODY TA IS + BEGIN + DECLARE -- THIS BLOCK TO CHECK THAT TAB + -- TERMINATES. + TASK TAB IS + END TAB; + + TASK BODY TAB IS + BEGIN + TX.E; + FAILED ( "RENDEZVOUS COMPLETED " & + "WITHOUT ERROR - TAB" ); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "ABNORMAL EXCEPTION " & + "- TAB" ); + END TAB; + BEGIN + NULL; + END; + + TX.E; --TX IS NOW TERMINATED. + + FAILED ( "RENDEZVOUS COMPLETED WITHOUT ERROR " & + "- TA" ); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "ABNORMAL EXCEPTION - TA" ); + END TA; + + PACKAGE RAISE_IT IS + TASK TY IS -- WILL NEVER BE ACTIVATED. + ENTRY E; + END TY; + END RAISE_IT; + + TASK BODY TB IS + BEGIN + DECLARE -- THIS BLOCK TO CHECK THAT TBB + -- TERMINATES. + TASK TBB IS + END TBB; + + TASK BODY TBB IS + BEGIN + RAISE_IT.TY.E; + FAILED ( "RENDEZVOUS COMPLETED " & + "WITHOUT ERROR - TBB" ); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "ABNORMAL EXCEPTION " & + "- TBB" ); + END TBB; + BEGIN + NULL; + END; + + RAISE_IT.TY.E; -- TY IS NOW TERMINATED. + + FAILED ( "RENDEZVOUS COMPLETED WITHOUT ERROR " & + "- TB" ); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "ABNORMAL EXCEPTION - TB" ); + END TB; + + PACKAGE START_TC IS END START_TC; + + TASK BODY TX IS + BEGIN + FAILED ( "TX ACTIVATED" ); + -- IN CASE OF FAILURE. + LOOP + SELECT + ACCEPT E; + OR + TERMINATE; + END SELECT; + END LOOP; + END TX; + + PACKAGE START_TZ IS + TASK TZ IS -- WILL NEVER BE ACTIVATED. + ENTRY E; + END TZ; + END START_TZ; + + PACKAGE BODY START_TC IS + TBREC1 : TBREC; -- CHECKS THAT TY TERMINATES. + + TASK TC IS -- CHECKS THAT TZ TERMINATES. + END TC; + + TASK BODY TC IS + BEGIN + DECLARE -- THIS BLOCK TO CHECK THAT TCB + -- TERMINATES. + + TASK TCB IS + END TCB; + + TASK BODY TCB IS + BEGIN + START_TZ.TZ.E; + FAILED ( "RENDEZVOUS COMPLETED " & + "WITHOUT " & + "ERROR - TCB" ); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "ABNORMAL " & + "EXCEPTION - TCB" ); + END TCB; + BEGIN + NULL; + END; + + START_TZ.TZ.E; -- TZ IS NOW TERMINATED. + + FAILED ( "RENDEZVOUS COMPLETED WITHOUT " & + "ERROR - TC" ); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "ABNORMAL EXCEPTION - TC" ); + END TC; + END START_TC; -- TBREC1 AND TC ACTIVATED HERE. + + PACKAGE BODY RAISE_IT IS + NTA : ATA := NEW TA; -- NTA.ALL ACTIVATED HERE. + + TASK BODY TY IS + BEGIN + FAILED ( "TY ACTIVATED" ); + -- IN CASE OF FAILURE. + LOOP + SELECT + ACCEPT E; + OR + TERMINATE; + END SELECT; + END LOOP; + END TY; + + PACKAGE XCEPTION IS + I : POSITIVE := IDENT_INT (0); -- RAISE + -- CONSTRAINT_ERROR. + END XCEPTION; + + USE XCEPTION; + + BEGIN -- TY WOULD BE ACTIVATED HERE. + + IF I /= IDENT_INT (2) OR I = IDENT_INT (1) + 1 THEN + FAILED ( "PACKAGE DIDN'T RAISE EXCEPTION" ); + END IF; + END RAISE_IT; + + PACKAGE BODY START_TZ IS + TASK BODY TZ IS + BEGIN + FAILED ( "TZ ACTIVATED" ); + -- IN CASE OF FAILURE. + LOOP + SELECT + ACCEPT E; + OR + TERMINATE; + END SELECT; + END LOOP; + END TZ; + END START_TZ; -- TZ WOULD BE ACTIVATED HERE. + + BEGIN -- TX WOULD BE ACTIVATED HERE. + -- CAN'T LEAVE BLOCK UNTIL TA, TB, AND TC ARE TERM. + + FAILED ( "EXCEPTION NOT RAISED" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN TASKING_ERROR => + FAILED ( "TASKING_ERROR IN MAIN PROGRAM" ); + WHEN OTHERS => + FAILED ( "ABNORMAL EXCEPTION IN MAIN" ); + END; + + RESULT; + +END C93005B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005c.ada b/gcc/testsuite/ada/acats/tests/c9/c93005c.ada new file mode 100644 index 000000000..87322ee91 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93005c.ada @@ -0,0 +1,250 @@ +-- C93005C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE +-- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES +-- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A +-- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR. + +-- CASE 1: TASKS IN DECLARATIVE PART OF A BLOCK AND PACKAGE +-- SPECIFICATION. THE TASKS DEPEND ON THE DECLARATIVE PART. + +-- RAC 19-MAR-1985 +-- JBG 06/03/85 +-- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PRAGMA ELABORATE (REPORT); + +with Impdef; + +PACKAGE C93005C_PK1 IS + + -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED. + TASK TYPE UNACTIVATED IS + ENTRY E; + END UNACTIVATED; + + TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED; + + -- ******************************************* + -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + -- + -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT + -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS + -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE + -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED. + -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT + -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR + -- DECREMENT). + + -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED + -- BY ANYONE BUT THEMSELVES. + -- + TASK TYPE MNT_TASK IS + END MNT_TASK; + + FUNCTION F RETURN INTEGER; + + -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK + -- AND FORCE CALLING F BEFORE CREATING THE TASK. + -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE + -- COUNT. + -- + TYPE MNT IS + RECORD + DUMMY : INTEGER := F; + T : MNT_TASK; + END RECORD; + + PROCEDURE CHECK; + + + -- ******************************************* + -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + +END C93005C_PK1; + + +PACKAGE BODY C93005C_PK1 IS + +-- THIS TASK IS CALLED IF AN UNACTIVATED TASK +-- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE. + + TASK T IS + ENTRY E; + END; + + -- *********************************************** + -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + +-- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND +-- ARE STILL ACTIVE. + + MNT_COUNT : INTEGER := 0; + +-- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE + + TASK MNT_COUNTER IS + ENTRY INCR; + ENTRY DECR; + END MNT_COUNTER; + +-- SYNCHRONIZING TASK + + TASK BODY MNT_COUNTER IS + BEGIN + LOOP + SELECT + ACCEPT INCR DO + MNT_COUNT := MNT_COUNT +1; + END INCR; + + OR ACCEPT DECR DO + MNT_COUNT := MNT_COUNT -1; + END DECR; + + OR TERMINATE; + + END SELECT; + END LOOP; + END MNT_COUNTER; + +-- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED +-- + FUNCTION F RETURN INTEGER IS + BEGIN + MNT_COUNTER.INCR; + RETURN 0; + END F; + +-- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE +-- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK +-- ITSELF IS NOT TERMINATED. +-- + PROCEDURE CHECK IS + BEGIN + IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN + FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " & + "TERMINATED"); + END IF; +-- RESET THE COUNT FOR THE NEXT SUBTEST: + MNT_COUNT := 0; + END CHECK; + +-- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH +-- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN +-- DECREMENT THE COUNTER. +-- + TASK BODY MNT_TASK IS + BEGIN + DELAY 5.0 * Impdef.One_Second; + MNT_COUNTER.DECR; + END MNT_TASK; + + -- *********************************************** + -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E DO + FAILED ("SOME TYPE U TASK WAS ACTIVATED"); + END E; + + OR TERMINATE; + END SELECT; + END LOOP; + END T; + + -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED. + -- + TASK BODY UNACTIVATED IS + BEGIN + T.E; + END UNACTIVATED; +END C93005C_PK1; + +WITH REPORT, C93005C_PK1; +USE REPORT, C93005C_PK1; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93005C IS + + +BEGIN + + TEST("C93005C", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " & + "TASKS"); + + COMMENT("SUBTEST 1: TASKS IN DECL PART OF A BLOCK AND A PACKAGE " & + "SPEC"); + COMMENT(" THE TASKS DEPEND ON THE DECLARATIVE PART"); +B1: DECLARE + X : MNT; + BEGIN +B2: BEGIN +B3: DECLARE + TYPE ACC_MNT IS ACCESS MNT; + T1 : UNACTIVATED; + M2 : ACC_MNT := NEW MNT; + + PACKAGE RAISES_EXCEPTION IS + T2 : UNACTIVATED; + M3 : ACC_MNT := NEW MNT; + I : POSITIVE := IDENT_INT(0); -- RAISE + -- CONSTRAINT_ERROR EXCEPTION + END RAISES_EXCEPTION; + USE RAISES_EXCEPTION; + BEGIN -- WOULD HAVE BEEN ACTIVATED HERE + IF EQUAL (I, I) THEN + FAILED ("EXCEPTION NOT RAISED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG SCOPE"); + END B3; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("SUBTEST 1 COMPLETED"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN B2"); + END B2; + END B1; + + CHECK; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + RESULT; +END C93005C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005d.ada b/gcc/testsuite/ada/acats/tests/c9/c93005d.ada new file mode 100644 index 000000000..70925a1f6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93005d.ada @@ -0,0 +1,289 @@ +-- C93005D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE +-- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES +-- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A +-- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR. + +-- CASE 2: TASKS IN DECLARATIVE PART OF A BLOCK AND PACKAGE +-- SPECIFICATION. THE TASKS DEPEND ON THE DECLARATIVE PART. +-- OTHER TASKS HAVE BEEN QUEUED ON THE TASKS' ENTRIES. + +-- RAC 19-MAR-1985 +-- JBG 06/03/85 +-- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. +-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. +-- ADDED PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + +with Impdef; + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PRAGMA ELABORATE (REPORT); +PACKAGE C93005D_PK1 IS + + -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED. + TASK TYPE UNACTIVATED IS + ENTRY E; + END UNACTIVATED; + + TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED; + + -- ******************************************* + -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + -- + -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT + -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS + -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE + -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED. + -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT + -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR + -- DECREMENT). + + -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED + -- BY ANYONE BUT THEMSELVES. + -- + TASK TYPE MNT_TASK IS + END MNT_TASK; + + FUNCTION F RETURN INTEGER; + + -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK + -- AND FORCE CALLING F BEFORE CREATING THE TASK. + -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE + -- COUNT. + -- + TYPE MNT IS + RECORD + DUMMY : INTEGER := F; + T : MNT_TASK; + END RECORD; + + PROCEDURE CHECK; + + + -- ******************************************* + -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + +END C93005D_PK1; + + +PACKAGE BODY C93005D_PK1 IS + +-- THIS TASK IS CALLED IF AN UNACTIVATED TASK +-- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE. + + TASK T IS + ENTRY E; + END; + + -- *********************************************** + -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + +-- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND +-- ARE STILL ACTIVE. + + MNT_COUNT : INTEGER := 0; + +-- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE + + TASK MNT_COUNTER IS + ENTRY INCR; + ENTRY DECR; + END MNT_COUNTER; + +-- SYNCHRONIZING TASK + + TASK BODY MNT_COUNTER IS + BEGIN + LOOP + SELECT + ACCEPT INCR DO + MNT_COUNT := MNT_COUNT +1; + END INCR; + + OR ACCEPT DECR DO + MNT_COUNT := MNT_COUNT -1; + END DECR; + + OR TERMINATE; + + END SELECT; + END LOOP; + END MNT_COUNTER; + +-- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED +-- + FUNCTION F RETURN INTEGER IS + BEGIN + MNT_COUNTER.INCR; + RETURN 0; + END F; + +-- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE +-- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK +-- ITSELF IS NOT TERMINATED. +-- + PROCEDURE CHECK IS + BEGIN + IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN + FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " & + "TERMINATED"); + END IF; +-- RESET THE COUNT FOR THE NEXT SUBTEST: + MNT_COUNT := 0; + END CHECK; + +-- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH +-- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN +-- DECREMENT THE COUNTER. +-- + TASK BODY MNT_TASK IS + BEGIN + DELAY 5.0 * Impdef.One_Second; + MNT_COUNTER.DECR; + END MNT_TASK; + + -- *********************************************** + -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E DO + FAILED ("SOME TYPE U TASK WAS ACTIVATED"); + END E; + + OR TERMINATE; + END SELECT; + END LOOP; + END T; + + -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED. + -- + TASK BODY UNACTIVATED IS + BEGIN + T.E; + END UNACTIVATED; +END C93005D_PK1; + +WITH C93005D_PK1; USE C93005D_PK1; +PRAGMA ELABORATE (C93005D_PK1); +GENERIC + T1 : IN OUT UNACTIVATED; +PACKAGE C93005D_ENQUEUE IS + PROCEDURE REQUIRE_BODY; +END; + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PRAGMA ELABORATE (REPORT); +PACKAGE BODY C93005D_ENQUEUE IS + + TASK T3 IS + END T3; + + TASK BODY T3 IS + BEGIN + T1.E; + FAILED ("ENQUEUED CALLER DID NOT GET EXCEPTION"); + EXCEPTION + WHEN TASKING_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED"); + END T3; + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; +BEGIN -- T3 CALLS T1 HERE + DELAY 1.0 * Impdef.One_Second; -- ENSURE THAT T3 EXECUTES +END C93005D_ENQUEUE; + +WITH REPORT, C93005D_PK1, C93005D_ENQUEUE; +USE REPORT, C93005D_PK1; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93005D IS + + +BEGIN + + TEST("C93005D", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " & + "TASKS"); + + COMMENT("SUBTEST 2: TASKS IN DECL PART OF A BLOCK AND A PACKAGE " & + "SPEC"); + COMMENT(" THE TASKS DEPEND ON THE DECLARATIVE PART"); + COMMENT(" OTHER TASKS HAVE BEEN ENQUEUED ON THE TASKS' ENTRIES"); +B21: DECLARE + X : MNT; + BEGIN +B22: BEGIN +B23: DECLARE + TYPE ACC_MNT IS ACCESS MNT; + T1 : UNACTIVATED; + Y : ACC_MNT := NEW MNT; + + PACKAGE HAS_UNACTIVATED IS + T2 : UNACTIVATED; + Z : ACC_MNT := NEW MNT; + PACKAGE ENQUEUE1 IS NEW C93005D_ENQUEUE(T1); + PACKAGE ENQUEUE2 IS NEW C93005D_ENQUEUE(T2); + I : POSITIVE := IDENT_INT(0); -- RAISE + -- CONSTRAINT_ERROR EXCEPTION. + -- TERMINATES T1 AND T2 AND INDIRECTLY THE 2 T3'S + END HAS_UNACTIVATED; + USE HAS_UNACTIVATED; + BEGIN -- WOULD HAVE BEEN ACTIVATED HERE + IF EQUAL (I, I) THEN + FAILED ("EXCEPTION NOT RAISED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG SCOPE"); + END B23; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT("SUBTEST 2 COMPLETED"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN B22"); + END B22; + END B21; + + CHECK; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + RESULT; +END C93005D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005e.ada b/gcc/testsuite/ada/acats/tests/c9/c93005e.ada new file mode 100644 index 000000000..c5d6e29e1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93005e.ada @@ -0,0 +1,247 @@ +-- C93005E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE +-- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES +-- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A +-- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR. + +-- CASE 3: TASKS IN PACKAGE SPECIFICATION. +-- THE TASKS DON'T DEPEND ON THE PACKAGE SPECIFICATION. + +-- RAC 19-MAR-1985 +-- JBG 06/03/85 +-- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PRAGMA ELABORATE (REPORT); +PACKAGE C93005E_PK1 IS + + -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED. + TASK TYPE UNACTIVATED IS + ENTRY E; + END UNACTIVATED; + + TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED; + + TYPE BAD_REC IS + RECORD + T : UNACTIVATED; + I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR. + END RECORD; + + TYPE ACC_BAD_REC IS ACCESS BAD_REC; + + + -- ******************************************* + -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + -- + -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT + -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS + -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE + -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED. + -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT + -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR + -- DECREMENT). + + -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED + -- BY ANYONE BUT THEMSELVES. + -- + TASK TYPE MNT_TASK IS + END MNT_TASK; + + FUNCTION F RETURN INTEGER; + + -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK + -- AND FORCE CALLING F BEFORE CREATING THE TASK. + -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE + -- COUNT. + -- + TYPE MNT IS + RECORD + DUMMY : INTEGER := F; + T : MNT_TASK; + END RECORD; + + PROCEDURE CHECK; + + + -- ******************************************* + -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + +END C93005E_PK1; + +with Impdef; +PACKAGE BODY C93005E_PK1 IS + +-- THIS TASK IS CALLED IF AN UNACTIVATED TASK +-- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE. + + TASK T IS + ENTRY E; + END; + + -- *********************************************** + -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + +-- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND +-- ARE STILL ACTIVE. + + MNT_COUNT : INTEGER := 0; + +-- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE + + TASK MNT_COUNTER IS + ENTRY INCR; + ENTRY DECR; + END MNT_COUNTER; + +-- SYNCHRONIZING TASK + + TASK BODY MNT_COUNTER IS + BEGIN + LOOP + SELECT + ACCEPT INCR DO + MNT_COUNT := MNT_COUNT +1; + END INCR; + + OR ACCEPT DECR DO + MNT_COUNT := MNT_COUNT -1; + END DECR; + + OR TERMINATE; + + END SELECT; + END LOOP; + END MNT_COUNTER; + +-- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED +-- + FUNCTION F RETURN INTEGER IS + BEGIN + MNT_COUNTER.INCR; + RETURN 0; + END F; + +-- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE +-- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK +-- ITSELF IS NOT TERMINATED. +-- + PROCEDURE CHECK IS + BEGIN + IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN + FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " & + "TERMINATED"); + END IF; +-- RESET THE COUNT FOR THE NEXT SUBTEST: + MNT_COUNT := 0; + END CHECK; + +-- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH +-- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN +-- DECREMENT THE COUNTER. +-- + TASK BODY MNT_TASK IS + BEGIN + DELAY 5.0 * Impdef.One_Second; + MNT_COUNTER.DECR; + END MNT_TASK; + + -- *********************************************** + -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E DO + FAILED ("SOME TYPE U TASK WAS ACTIVATED"); + END E; + + OR TERMINATE; + END SELECT; + END LOOP; + END T; + + -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED. + -- + TASK BODY UNACTIVATED IS + BEGIN + T.E; + END UNACTIVATED; +END C93005E_PK1; + +WITH REPORT, C93005E_PK1; +USE REPORT, C93005E_PK1; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93005E IS + + +BEGIN + + TEST("C93005E", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " & + "TASKS"); + + COMMENT("SUBTEST 3: TASK IN DECL PART OF PACKAGE SPEC"); + COMMENT(" THE TASKS DON'T DEPEND ON THE DECLARATIVE PART"); +B31: DECLARE + X : MNT; + BEGIN +B32: BEGIN +B33: DECLARE + PACKAGE RAISES_EXCEPTION IS + TYPE ACC_MNT IS ACCESS MNT; + Y : ACC_MNT := NEW MNT; + PTR : ACC_BAD_REC := NEW BAD_REC; + END RAISES_EXCEPTION; + BEGIN -- WOULD HAVE BEEN ACTIVATED HERE + FAILED("EXCEPTION NOT RAISED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG SCOPE"); + END B33; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT("SUBTEST 3 COMPLETED"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN B32"); + END B32; + END B31; + + CHECK; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + RESULT; +END C93005E; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005f.ada b/gcc/testsuite/ada/acats/tests/c9/c93005f.ada new file mode 100644 index 000000000..c6d6aeb17 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93005f.ada @@ -0,0 +1,255 @@ +-- C93005F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE +-- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES +-- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A +-- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR. + +-- CASE 4: TASKS IN STATEMENT PART OF A BLOCK. THE TASKS DEPEND ON THE +-- DECLARATIVE PART. + +-- RAC 19-MAR-1985 +-- JBG 06/03/85 +-- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. +-- RLB 06/29/01 CORRECTED TO ALLOW AGGRESSIVE OPTIMIZATION. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PRAGMA ELABORATE (REPORT); +PACKAGE C93005F_PK1 IS + + -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED. + TASK TYPE UNACTIVATED IS + ENTRY E; + END UNACTIVATED; + + TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED; + + TYPE BAD_REC IS + RECORD + T : UNACTIVATED; + I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR. + END RECORD; + + TYPE ACC_BAD_REC IS ACCESS BAD_REC; + + + -- ******************************************* + -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + -- + -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT + -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS + -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE + -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED. + -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT + -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR + -- DECREMENT). + + -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED + -- BY ANYONE BUT THEMSELVES. + -- + TASK TYPE MNT_TASK IS + END MNT_TASK; + + FUNCTION F RETURN INTEGER; + + -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK + -- AND FORCE CALLING F BEFORE CREATING THE TASK. + -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE + -- COUNT. + -- + TYPE MNT IS + RECORD + DUMMY : INTEGER := F; + T : MNT_TASK; + END RECORD; + + PROCEDURE CHECK; + + + -- ******************************************* + -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + +END C93005F_PK1; + +with Impdef; +PACKAGE BODY C93005F_PK1 IS + +-- THIS TASK IS CALLED IF AN UNACTIVATED TASK +-- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE. + + TASK T IS + ENTRY E; + END; + + -- *********************************************** + -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + +-- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND +-- ARE STILL ACTIVE. + + MNT_COUNT : INTEGER := 0; + +-- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE + + TASK MNT_COUNTER IS + ENTRY INCR; + ENTRY DECR; + END MNT_COUNTER; + +-- SYNCHRONIZING TASK + + TASK BODY MNT_COUNTER IS + BEGIN + LOOP + SELECT + ACCEPT INCR DO + MNT_COUNT := MNT_COUNT +1; + END INCR; + + OR ACCEPT DECR DO + MNT_COUNT := MNT_COUNT -1; + END DECR; + + OR TERMINATE; + + END SELECT; + END LOOP; + END MNT_COUNTER; + +-- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED +-- + FUNCTION F RETURN INTEGER IS + BEGIN + MNT_COUNTER.INCR; + RETURN 0; + END F; + +-- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE +-- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK +-- ITSELF IS NOT TERMINATED. +-- + PROCEDURE CHECK IS + BEGIN + IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN + FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " & + "TERMINATED"); + END IF; +-- RESET THE COUNT FOR THE NEXT SUBTEST: + MNT_COUNT := 0; + END CHECK; + +-- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH +-- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN +-- DECREMENT THE COUNTER. +-- + TASK BODY MNT_TASK IS + BEGIN + DELAY 5.0 * Impdef.One_Second; + MNT_COUNTER.DECR; + END MNT_TASK; + + -- *********************************************** + -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E DO + FAILED ("SOME TYPE U TASK WAS ACTIVATED"); + END E; + + OR TERMINATE; + END SELECT; + END LOOP; + END T; + + -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED. + -- + TASK BODY UNACTIVATED IS + BEGIN + T.E; + END UNACTIVATED; +END C93005F_PK1; + +WITH REPORT, C93005F_PK1; +USE REPORT, C93005F_PK1; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93005F IS + + +BEGIN + + TEST("C93005F", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " & + "TASKS"); + + COMMENT("SUBTEST 4: TASK IN STATEMENT PART OF BLOCK"); + COMMENT(" THE TASKS DEPEND ON THE DECLARATIVE PART"); +B41: DECLARE + X : MNT; + BEGIN +B42: DECLARE + TYPE LOCAL_ACC IS ACCESS BAD_REC; + Y : MNT; + PTR : LOCAL_ACC; + + TYPE ACC_MNT IS ACCESS MNT; + Z : ACC_MNT; + + BEGIN + Z := NEW MNT; + PTR := NEW BAD_REC; + IF PTR.I /= REPORT.IDENT_INT(0) THEN + FAILED ("EXCEPTION NOT RAISED, VALUE CHANGED"); + ELSE + FAILED ("EXCEPTION NOT RAISED, CONSTRAINT IGNORED"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION IN B42"); + END B42; + + COMMENT("SUBTEST 4: COMPLETED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + END B41; + + CHECK; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + RESULT; +END C93005F; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005g.ada b/gcc/testsuite/ada/acats/tests/c9/c93005g.ada new file mode 100644 index 000000000..c46a7309d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93005g.ada @@ -0,0 +1,245 @@ +-- C93005G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE +-- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES +-- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A +-- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR. + +-- CASE 5: TASKS IN STATEMENT PART OF A BLOCK. THE TASKS DON'T DEPEND +-- ON THE DECLARATIVE PART. + +-- RAC 19-MAR-1985 +-- JBG 06/03/85 +-- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PRAGMA ELABORATE (REPORT); +PACKAGE C93005G_PK1 IS + + -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED. + TASK TYPE UNACTIVATED IS + ENTRY E; + END UNACTIVATED; + + TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED; + + TYPE BAD_REC IS + RECORD + T : UNACTIVATED; + I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR. + END RECORD; + + TYPE ACC_BAD_REC IS ACCESS BAD_REC; + + + -- ******************************************* + -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + -- + -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT + -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS + -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE + -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED. + -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT + -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR + -- DECREMENT). + + -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED + -- BY ANYONE BUT THEMSELVES. + -- + TASK TYPE MNT_TASK IS + END MNT_TASK; + + FUNCTION F RETURN INTEGER; + + -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK + -- AND FORCE CALLING F BEFORE CREATING THE TASK. + -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE + -- COUNT. + -- + TYPE MNT IS + RECORD + DUMMY : INTEGER := F; + T : MNT_TASK; + END RECORD; + + PROCEDURE CHECK; + + + -- ******************************************* + -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + +END C93005G_PK1; + +with Impdef; +PACKAGE BODY C93005G_PK1 IS + +-- THIS TASK IS CALLED IF AN UNACTIVATED TASK +-- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE. + + TASK T IS + ENTRY E; + END; + + -- *********************************************** + -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + +-- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND +-- ARE STILL ACTIVE. + + MNT_COUNT : INTEGER := 0; + +-- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE + + TASK MNT_COUNTER IS + ENTRY INCR; + ENTRY DECR; + END MNT_COUNTER; + +-- SYNCHRONIZING TASK + + TASK BODY MNT_COUNTER IS + BEGIN + LOOP + SELECT + ACCEPT INCR DO + MNT_COUNT := MNT_COUNT +1; + END INCR; + + OR ACCEPT DECR DO + MNT_COUNT := MNT_COUNT -1; + END DECR; + + OR TERMINATE; + + END SELECT; + END LOOP; + END MNT_COUNTER; + +-- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED +-- + FUNCTION F RETURN INTEGER IS + BEGIN + MNT_COUNTER.INCR; + RETURN 0; + END F; + +-- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE +-- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK +-- ITSELF IS NOT TERMINATED. +-- + PROCEDURE CHECK IS + BEGIN + IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN + FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " & + "TERMINATED"); + END IF; +-- RESET THE COUNT FOR THE NEXT SUBTEST: + MNT_COUNT := 0; + END CHECK; + +-- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH +-- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN +-- DECREMENT THE COUNTER. +-- + TASK BODY MNT_TASK IS + BEGIN + DELAY 5.0 * Impdef.One_Second; + MNT_COUNTER.DECR; + END MNT_TASK; + + -- *********************************************** + -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E DO + FAILED ("SOME TYPE U TASK WAS ACTIVATED"); + END E; + + OR TERMINATE; + END SELECT; + END LOOP; + END T; + + -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED. + -- + TASK BODY UNACTIVATED IS + BEGIN + T.E; + END UNACTIVATED; +END C93005G_PK1; + +WITH REPORT, C93005G_PK1; +USE REPORT, C93005G_PK1; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93005G IS + + +BEGIN + + TEST("C93005G", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " & + "TASKS"); + + COMMENT("SUBTEST 5: TASK IN STATEMENT PART OF BLOCK"); + COMMENT(" THE TASKS DON'T DEPEND ON THE DECLARATIVE PART"); +B51: DECLARE + X : MNT; + BEGIN +B52: DECLARE + Y : MNT; + PTR : ACC_BAD_REC; + BEGIN + PTR := NEW BAD_REC; + FAILED ("EXCEPTION NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION IN B52"); + END B52; + + COMMENT ("SUBTEST 5: COMPLETED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + END B51; + + CHECK; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + RESULT; +END C93005G; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93005h.ada b/gcc/testsuite/ada/acats/tests/c9/c93005h.ada new file mode 100644 index 000000000..6641347b1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93005h.ada @@ -0,0 +1,250 @@ +-- C93005H.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE +-- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES +-- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A +-- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR. + +-- CASE 6: TASK IN STATEMENT PART OF PACKAGE AND THE TASKS DON'T DEPEND +-- ON THE PACKAGE SPECIFICATION. + +-- RAC 19-MAR-1985 +-- JBG 06/03/85 +-- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PRAGMA ELABORATE (REPORT); +PACKAGE C93005H_PK1 IS + + -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED. + TASK TYPE UNACTIVATED IS + ENTRY E; + END UNACTIVATED; + + TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED; + + TYPE BAD_REC IS + RECORD + T : UNACTIVATED; + I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR. + END RECORD; + + TYPE ACC_BAD_REC IS ACCESS BAD_REC; + + + -- ******************************************* + -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + -- + -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT + -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS + -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE + -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED. + -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT + -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR + -- DECREMENT). + + -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED + -- BY ANYONE BUT THEMSELVES. + -- + TASK TYPE MNT_TASK IS + END MNT_TASK; + + FUNCTION F RETURN INTEGER; + + -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK + -- AND FORCE CALLING F BEFORE CREATING THE TASK. + -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE + -- COUNT. + -- + TYPE MNT IS + RECORD + DUMMY : INTEGER := F; + T : MNT_TASK; + END RECORD; + + PROCEDURE CHECK; + + + -- ******************************************* + -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + +END C93005H_PK1; + +with Impdef; +PACKAGE BODY C93005H_PK1 IS + +-- THIS TASK IS CALLED IF AN UNACTIVATED TASK +-- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE. + + TASK T IS + ENTRY E; + END; + + -- *********************************************** + -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + +-- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND +-- ARE STILL ACTIVE. + + MNT_COUNT : INTEGER := 0; + +-- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE + + TASK MNT_COUNTER IS + ENTRY INCR; + ENTRY DECR; + END MNT_COUNTER; + +-- SYNCHRONIZING TASK + + TASK BODY MNT_COUNTER IS + BEGIN + LOOP + SELECT + ACCEPT INCR DO + MNT_COUNT := MNT_COUNT +1; + END INCR; + + OR ACCEPT DECR DO + MNT_COUNT := MNT_COUNT -1; + END DECR; + + OR TERMINATE; + + END SELECT; + END LOOP; + END MNT_COUNTER; + +-- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED +-- + FUNCTION F RETURN INTEGER IS + BEGIN + MNT_COUNTER.INCR; + RETURN 0; + END F; + +-- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE +-- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK +-- ITSELF IS NOT TERMINATED. +-- + PROCEDURE CHECK IS + BEGIN + IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN + FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " & + "TERMINATED"); + END IF; +-- RESET THE COUNT FOR THE NEXT SUBTEST: + MNT_COUNT := 0; + END CHECK; + +-- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH +-- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN +-- DECREMENT THE COUNTER. +-- + TASK BODY MNT_TASK IS + BEGIN + DELAY 5.0 * Impdef.One_Second; + MNT_COUNTER.DECR; + END MNT_TASK; + + -- *********************************************** + -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E DO + FAILED ("SOME TYPE U TASK WAS ACTIVATED"); + END E; + + OR TERMINATE; + END SELECT; + END LOOP; + END T; + + -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED. + -- + TASK BODY UNACTIVATED IS + BEGIN + T.E; + END UNACTIVATED; +END C93005H_PK1; + +WITH REPORT, C93005H_PK1; +USE REPORT, C93005H_PK1; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C93005H IS + + +BEGIN + + TEST("C93005H", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " & + "TASKS"); + + COMMENT("SUBTEST 6: TASK IN STATEMENT PART OF PACKAGE"); + COMMENT(" THE TASKS DON'T DEPEND ON THE DECLARATIVE PART"); +B61: DECLARE + X : MNT; + + PACKAGE P IS + Y : MNT; + END P; + + PACKAGE BODY P IS + PTR : ACC_BAD_REC; + Z : MNT; + BEGIN + PTR := NEW BAD_REC; + FAILED("EXCEPTION NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN P"); + END P; + + BEGIN + COMMENT ("SUBTEST 6: COMPLETED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + END B61; + + CHECK; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + RESULT; +END C93005H; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93006a.ada b/gcc/testsuite/ada/acats/tests/c9/c93006a.ada new file mode 100644 index 000000000..81954f247 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93006a.ada @@ -0,0 +1,69 @@ +-- C93006A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TASK OBJECT DECLARED IN A LIBRARY PACKAGE SPEC IS +-- ACTIVATED EVEN IF THE PACKAGE HAS NO BODY. + +-- JEAN-PIERRE ROSEN 16-MAR-1984 +-- JBG 6/1/84 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +WITH SYSTEM; USE SYSTEM; +PACKAGE C93006A0 IS + TASK TYPE TT IS + ENTRY E; + END; +END C93006A0; + +PACKAGE BODY C93006A0 IS + TASK BODY TT IS + BEGIN + ACCEPT E; + END; +END C93006A0; + +WITH C93006A0; USE C93006A0; +PRAGMA ELABORATE(C93006A0); +PACKAGE C93006A1 IS + T : TT; +END C93006A1; + +with Impdef; +WITH REPORT, C93006A1, SYSTEM; +USE REPORT, C93006A1, SYSTEM; +PROCEDURE C93006A IS +BEGIN + + TEST("C93006A", "CHECK ACTIVATION OF TASK DECLARED IN PACKAGE " & + "SPECIFICATION"); + + SELECT + T.E; + OR + DELAY 60.0 * Impdef.One_Second; + FAILED("RENDEZVOUS NOT ACCEPTED WITHIN 60 SECONDS"); + END SELECT; + + RESULT; +END C93006A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93007a.ada b/gcc/testsuite/ada/acats/tests/c9/c93007a.ada new file mode 100644 index 000000000..9653d662e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93007a.ada @@ -0,0 +1,113 @@ +-- C93007A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT IF AN ATTEMPT IS MADE TO ACTIVATE A TASK BEFORE ITS +-- BODY HAS BEEN ELABORATED, THE TASK IS COMPLETED AND "PROGRAM_ +-- ERROR" (RATHER THAN "TASKING_ERROR") IS RAISED. + +-- HISTORY: +-- DHH 03/16/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C93007A IS + +BEGIN + + TEST("C93007A", "CHECK THAT IF AN ATTEMPT IS MADE TO ACTIVATE " & + "A TASK BEFORE ITS BODY HAS BEEN ELABORATED, " & + "THE TASK IS COMPLETED AND ""PROGRAM_ERROR"" " & + "(RATHER THAN ""TASKING_ERROR"") IS RAISED"); + + DECLARE + TASK TYPE PROG_ERR IS + ENTRY START; + END PROG_ERR; + + TYPE REC IS + RECORD + B : PROG_ERR; + END RECORD; + + TYPE ACC IS ACCESS PROG_ERR; + + PACKAGE P IS + OBJ : REC; + END P; + + PACKAGE BODY P IS + BEGIN + FAILED("EXCEPTION NOT RAISED - 1"); + OBJ.B.START; + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN TASKING_ERROR => + FAILED("TASKING ERROR RAISED INCORRECTLY"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED"); + END P; + + PACKAGE Q IS + OBJ : ACC; + END Q; + + PACKAGE BODY Q IS + BEGIN + OBJ := NEW PROG_ERR; + FAILED("EXCEPTION NOT RAISED - 2"); + OBJ.START; + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN TASKING_ERROR => + FAILED("ACCESS TASKING ERROR RAISED INCORRECTLY"); + WHEN OTHERS => + FAILED("ACCESS UNEXPECTED EXCEPTION RAISED"); + END; + + TASK BODY PROG_ERR IS + BEGIN + ACCEPT START DO + IF TRUE THEN + COMMENT("IRRELEVANT"); + END IF; + END START; + END PROG_ERR; + BEGIN + NULL; + END; -- DECLARE + + RESULT; + +EXCEPTION + WHEN PROGRAM_ERROR => + FAILED("PROGRAM_ERROR RAISED AT INCORRECT POSITION"); + RESULT; + + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED"); + RESULT; + +END C93007A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93008a.ada b/gcc/testsuite/ada/acats/tests/c9/c93008a.ada new file mode 100644 index 000000000..633d17dbc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93008a.ada @@ -0,0 +1,108 @@ +-- C93008A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT FOR A TASK CREATED BY AN OBJECT DECLARATION, EXECUTION +-- DOES NOT PROCEED IN PARALLEL WITH ACTIVATION. + +-- R.WILLIAMS 8/20/86 + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C93008A IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + TASK T IS + ENTRY FINIT_POS (DIGT : IN ARG); + END T; + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT FINIT_POS (DIGT : IN ARG) DO + SPYNUMB := 10*SPYNUMB+DIGT; + END FINIT_POS; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + +BEGIN + + TEST ("C93008A", "CHECK THAT EXECUTION DOES NOT PROCEED IN " & + "PARALLEL WITH ACTIVATION OF A TASK CREATED " & + "BY AN OBJECT DECLARATION"); + +BLOCK: + DECLARE + + TASK TYPE TT1; + + TASK TT2; + + T1 : TT1; + + TASK BODY TT1 IS + PACKAGE DUMMY IS + END DUMMY; + + PACKAGE BODY DUMMY IS + BEGIN + DELAY 2.0 * Impdef.One_Second; + T.FINIT_POS(1); + END DUMMY; + BEGIN + NULL; + END TT1; + + TASK BODY TT2 IS + PACKAGE DUMMY IS + END DUMMY; + + PACKAGE BODY DUMMY IS + BEGIN + DELAY 2.0 * Impdef.One_Second; + T.FINIT_POS(2); + END DUMMY; + BEGIN + NULL; + END TT2; + + + BEGIN -- TASKS ACTIVATED NOW. + + IF SPYNUMB = 12 OR SPYNUMB = 21 THEN + NULL; + ELSE + FAILED ("TASKS NOT ACTIVATED PROPERLY - SPYNUMB HAS " & + "ACTUAL VALUE OF: " & INTEGER'IMAGE(SPYNUMB)); + END IF; + END BLOCK; + + RESULT; + +END C93008A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c93008b.ada b/gcc/testsuite/ada/acats/tests/c9/c93008b.ada new file mode 100644 index 000000000..2853acd4e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c93008b.ada @@ -0,0 +1,103 @@ +-- C93008B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT AFTER CREATION OF A TASK OBJECT BY AN ALLOCATOR, ANY +-- OPERATION INVOLVING THE RESULT DELIVERED BY THE ALLOCATOR IS +-- EXECUTED ONLY AFTER THE ACTIVATION OF THE TASK HAS COMPLETED. + +-- WEI 3/ 4/82 +-- TBN 12/20/85 RENAMED FROM C930AJA-B.ADA. ADDED DELAY STATEMENT +-- DURING TASK ACTIVATION. +-- RJW 4/11/86 ADDED PACKAGE DUMMY. + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C93008B IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + FUNCTION FINIT_POS (DIGT: IN ARG) RETURN NATURAL IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + RETURN DIGT; + END FINIT_POS; + +BEGIN + + TEST ("C93008B", "USE OF RESULT AFTER CREATION OF " & + "A TASK BY ALLOCATOR"); + +BLOCK: + DECLARE + + TASK TYPE TT1; + + TYPE ATT1 IS ACCESS TT1; + TYPE ARRAY_ATT1 IS ARRAY (NATURAL RANGE 2 .. 3) OF ATT1; + MY_ARRAY : ARRAY_ATT1; + POINTER_TT1 : ATT1; + + TASK BODY TT1 IS + PACKAGE DUMMY IS + END DUMMY; + + PACKAGE BODY DUMMY IS + BEGIN + DELAY 2.0 * Impdef.One_Second; + DECLARE + IDUMMY1 : NATURAL := FINIT_POS (1); + BEGIN + NULL; + END; + END DUMMY; + BEGIN + NULL; + END TT1; + + BEGIN + + MY_ARRAY := (2 => NEW TT1, 3 => NULL); -- TASK ACTIVATED NOW. + POINTER_TT1 := MY_ARRAY (FINIT_POS (2)); + + MY_ARRAY (FINIT_POS (3)) := POINTER_TT1; + + IF SPYNUMB /= 123 THEN + IF SPYNUMB = 132 OR SPYNUMB = 13 OR + SPYNUMB = 12 OR SPYNUMB = 1 OR + SPYNUMB = 0 + THEN + FAILED ("TASK ACTIVATION RIGHT IN TIME, " & + "BUT OTHER ERROR"); + ELSE + FAILED ("RESULT OF ALLOCATOR ACCESSED BEFORE " & + "TASK ACTIVATION HAS COMPLETED"); + END IF; + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + END BLOCK; + + RESULT; + +END C93008B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940001.a b/gcc/testsuite/ada/acats/tests/c9/c940001.a new file mode 100644 index 000000000..2bc1a9ffd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940001.a @@ -0,0 +1,212 @@ +-- C940001.A +-- +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a protected object provides coordinated access to +-- shared data. Check that it can be used to sequence a number of tasks. +-- Use the protected object to control a single token for which three +-- tasks compete. Check that only one task is running at a time and that +-- all tasks get a chance to run sometime. +-- +-- TEST DESCRIPTION: +-- Declare a protected type with two entries. A task may call the Take +-- entry to get a token which allows it to continue processing. If it +-- has the token, it may call the Give entry to return it. The tasks +-- implement a discipline whereby only the task with the token may be +-- active. The test does not require any specific order for the tasks +-- to run. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 07 Jul 96 SAIC Fixed spelling nits. +-- +--! + +package C940001_0 is + + type Token_Type is private; + True_Token : constant Token_Type; -- Create a deferred constant in order + -- to provide a component init for the + -- protected object + + protected type Token_Mgr_Prot_Unit is + entry Take (T : out Token_Type); + entry Give (T : in out Token_Type); + private + Token : Token_Type := True_Token; + end Token_Mgr_Prot_Unit; + + function Init_Token return Token_Type; -- call to initialize an + -- object of Token_Type + function Token_Value (T : Token_Type) return Boolean; + -- call to inspect the value of an + -- object of Token_Type +private + type Token_Type is new boolean; + True_Token : constant Token_Type := true; +end C940001_0; + +--=================================================================-- + +package body C940001_0 is + protected body Token_Mgr_Prot_Unit is + entry Take (T : out Token_Type) when Token = true is + begin -- Calling task will Take the token, so + T := Token; -- check first that token_mgr owns the + Token := false; -- token to give, then give it to caller + end Take; + + entry Give (T : in out Token_Type) when Token = false is + begin -- Calling task will Give the token back, + if T = true then -- so first check that token_mgr does not + Token := T; -- own the token, then check that the task has + T := false; -- the token to give, then take it from the + end if; -- task + -- if caller does not own the token, then + end Give; -- it falls out of the entry body with no + end Token_Mgr_Prot_Unit; -- action + + function Init_Token return Token_Type is + begin + return false; + end Init_Token; + + function Token_Value (T : Token_Type) return Boolean is + begin + return Boolean (T); + end Token_Value; + +end C940001_0; + +--===============================================================-- + +with Report; +with ImpDef; +with C940001_0; + +procedure C940001 is + + type TC_Int_Type is range 0..2; + -- range is very narrow so that erroneous execution may + -- raise Constraint_Error + + type TC_Artifact_Type is record + TC_Int : TC_Int_Type := 1; + Number_of_Accesses : integer := 0; + end record; + + TC_Artifact : TC_Artifact_Type; + + Sequence_Mgr : C940001_0.Token_Mgr_Prot_Unit; + + procedure Bump (Item : in out TC_Int_Type) is + begin + Item := Item + 1; + exception + when Constraint_Error => + Report.Failed ("Incremented without corresponding decrement"); + when others => + Report.Failed ("Bump raised Unexpected Exception"); + end Bump; + + procedure Decrement (Item : in out TC_Int_Type) is + begin + Item := Item - 1; + exception + when Constraint_Error => + Report.Failed ("Decremented without corresponding increment"); + when others => + Report.Failed ("Decrement raised Unexpected Exception"); + end Decrement; + + --==============-- + + task type Network_Node_Type; + + task body Network_Node_Type is + + Slot_for_Token : C940001_0.Token_Type := C940001_0.Init_Token; + + begin + + -- Ask for token - if request is not granted, task will be queued + Sequence_Mgr.Take (Slot_for_Token); + + -- Task now has token and may perform its work + + --==========================-- + -- in this case, the work is to ensure that the test results + -- are the expected ones! + --==========================-- + Bump (TC_Artifact.TC_Int); -- increment when request is granted + TC_Artifact.Number_Of_Accesses := + TC_Artifact.Number_Of_Accesses + 1; + if not C940001_0.Token_Value ( Slot_for_Token) then + Report.Failed ("Incorrect results from entry Take"); + end if; + + -- give a chance for other tasks to (incorrectly) run + delay ImpDef.Minimum_Task_Switch; + + Decrement (TC_Artifact.TC_Int); -- prepare to return token + + -- Task has completed its work and will return token + + Sequence_Mgr.Give (Slot_for_Token); -- return token to sequence manager + + if c940001_0.Token_Value (Slot_for_Token) then + Report.Failed ("Incorrect results from entry Give"); + end if; + + exception + when others => Report.Failed ("Unexpected exception raised in task"); + + end Network_Node_Type; + + --==============-- + +begin + + Report.Test ("C940001", "Check that a protected object can control " & + "tasks by coordinating access to shared data"); + + declare + Node_1, Node_2, Node_3 : Network_Node_Type; + -- declare three tasks which will compete for + -- a single token, managed by Sequence Manager + + begin -- tasks start + null; + end; -- wait for all tasks to terminate before reporting result + + if TC_Artifact.Number_of_Accesses /= 3 then + Report.Failed ("Not all tasks got through"); + end if; + + Report.Result; + +end C940001; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940002.a b/gcc/testsuite/ada/acats/tests/c9/c940002.a new file mode 100644 index 000000000..420f54440 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940002.a @@ -0,0 +1,309 @@ +-- C940002.A +-- +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a protected object provides coordinated access to shared +-- data. Check that it can implement a semaphore-like construct using a +-- parameterless procedure which allows a specific maximum number of tasks +-- to run and excludes all others +-- +-- TEST DESCRIPTION: +-- Implement a counting semaphore type that can be initialized to a +-- specific number of available resources. Declare an entry for +-- requesting a resource and a procedure for releasing it. Declare an +-- object of this type, initialized to two resources. Declare and start +-- three tasks each of which asks for a resource. Verify that only two +-- resources are granted and that the last task in is queued. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +package C940002_0 is + -- Semaphores + + protected type Semaphore_Type (Resources_Available : Integer :=1) is + entry Request; + procedure Release; + function Available return Integer; + private + Currently_Available : Integer := Resources_Available; + end Semaphore_Type; + + Max_Resources : constant Integer := 2; + Resource : Semaphore_Type (Max_Resources); + +end C940002_0; + -- Semaphores; + + + --========================================================-- + + +package body C940002_0 is + -- Semaphores + + protected body Semaphore_Type is + + entry Request when Currently_Available >0 is -- when granted, secures + begin -- a resource + Currently_Available := Currently_Available - 1; + end Request; + + procedure Release is -- when called, releases + begin -- a resource + Currently_Available := Currently_Available + 1; + end Release; + + function Available return Integer is -- returns number of + begin -- available resources + return Currently_Available; + end Available; + + end Semaphore_Type; + +end C940002_0; + -- Semaphores; + + + --========================================================-- + + +package C940002_1 is + -- Task_Pkg + + task type Requesting_Task is + entry Done; -- call on Done instructs the task + end Requesting_Task; -- to release resource + + type Task_Ptr is access Requesting_Task; + + protected Counter is + procedure Increment; + procedure Decrement; + function Number return integer; + private + Count : Integer := 0; + end Counter; + + protected Hold_Lock is + procedure Lock; + procedure Unlock; + function Locked return Boolean; + private + Lock_State : Boolean := true; -- starts out locked + end Hold_Lock; + + +end C940002_1; + -- Task_Pkg + + + --========================================================-- + + +with Report; +with C940002_0; + -- Semaphores; + +package body C940002_1 is + -- Task_Pkg is + + protected body Counter is + + procedure Increment is + begin + Count := Count + 1; + end Increment; + + procedure Decrement is + begin + Count := Count - 1; + end Decrement; + + function Number return Integer is + begin + return Count; + end Number; + + end Counter; + + + protected body Hold_Lock is + + procedure Lock is + begin + Lock_State := true; + end Lock; + + procedure Unlock is + begin + Lock_State := false; + end Unlock; + + function Locked return Boolean is + begin + return Lock_State; + end Locked; + + end Hold_Lock; + + + task body Requesting_Task is + begin + C940002_0.Resource.Request; -- request a resource + -- if resource is not available, + -- task will be queued to wait + Counter.Increment; -- add to count of resources obtained + Hold_Lock.Unlock; -- and unlock Lock - system is stable; + -- status may now be queried + + accept Done do -- hold resource until Done is called + C940002_0.Resource.Release; -- release the resource and + Counter.Decrement; -- note release + end Done; + + exception + when others => Report.Failed ("Unexpected Exception in Requesting_Task"); + end Requesting_Task; + +end C940002_1; + -- Task_Pkg; + + + --========================================================-- + + +with Report; +with ImpDef; +with C940002_0, + -- Semaphores, + C940002_1; + -- Task_Pkg; + +procedure C940002 is + + package Semaphores renames C940002_0; + package Task_Pkg renames C940002_1; + + Ptr1, + Ptr2, + Ptr3 : Task_Pkg.Task_Ptr; + Num : Integer; + + procedure Spinlock is + begin + -- loop until unlocked + while Task_Pkg.Hold_Lock.Locked loop + delay ImpDef.Minimum_Task_Switch; + end loop; + Task_Pkg.Hold_Lock.Lock; + end Spinlock; + +begin + + Report.Test ("C940002", "Check that a protected record can be used to " & + "control access to resources"); + + if (Task_Pkg.Counter.Number /=0) + or (Semaphores.Resource.Available /= 2) then + Report.Failed ("Wrong initial conditions"); + end if; + + Ptr1 := new Task_Pkg.Requesting_Task; -- newly allocated task requests + -- resource; request for resource should + -- be granted + Spinlock; -- ensure that task obtains resource + + -- Task 1 waiting for call to Done + -- One resource assigned to task 1 + -- One resource still available + if (Task_Pkg.Counter.Number /= 1) + or (Semaphores.Resource.Available /= 1) then + Report.Failed ("Resource not assigned to task 1"); + end if; + + Ptr2 := new Task_Pkg.Requesting_Task; -- newly allocated task requests + -- resource; request for resource should + -- be granted + Spinlock; -- ensure that task obtains resource + + -- Task 1 waiting for call to Done + -- Task 2 waiting for call to Done + -- Resources held by tasks 1 and 2 + -- No resources available + if (Task_Pkg.Counter.Number /= 2) + or (Semaphores.Resource.Available /= 0) then + Report.Failed ("Resource not assigned to task 2"); + end if; + + Ptr3 := new Task_Pkg.Requesting_Task; -- newly allocated task requests + -- resource; request for resource should + -- be denied and task queued to wait for + -- next available resource + + + Ptr1.all.Done; -- Task 1 releases resource and lock + -- Resource should be given to queued task + Spinlock; -- ensure that resource is released + + + -- Task 1 holds no resource + -- One resource still assigned to task 2 + -- One resource assigned to task 3 + -- No resources available + if (Task_Pkg.Counter.Number /= 2) + or (Semaphores.Resource.Available /= 0) then + Report.Failed ("Resource not properly released/assigned to task 3"); + end if; + + Ptr2.all.Done; -- Task 2 releases resource and lock + -- No outstanding request for resource + + -- Tasks 1 and 2 hold no resources + -- One resource assigned to task 3 + -- One resource available + if (Task_Pkg.Counter.Number /= 1) + or (Semaphores.Resource.Available /= 1) then + Report.Failed ("Resource not properly released from task 2"); + end if; + + Ptr3.all.Done; -- Task 3 releases resource and lock + + -- All resources released + -- All tasks terminated (or close) + -- Two resources available + if (Task_Pkg.Counter.Number /=0) + or (Semaphores.Resource.Available /= 2) then + Report.Failed ("Resource not properly released from task 3"); + end if; + + Report.Result; + +end C940002; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940004.a b/gcc/testsuite/ada/acats/tests/c9/c940004.a new file mode 100644 index 000000000..059c97f41 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940004.a @@ -0,0 +1,416 @@ +-- C940004.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- TEST OBJECTIVE: +-- Check that a protected record can be used to control access to +-- resources (data internal to the protected record). +-- +-- TEST DESCRIPTION: +-- Declare a resource descriptor tagged type. Extend the type and +-- use the extended type in a protected data structure. +-- Implement a binary semaphore type. Declare an entry for +-- requesting a specific resource and an procedure for releasing the +-- same resource. Declare an object of this (protected) type. +-- Declare and start three tasks each of which asks for a resource +-- when directed to. Verify that resources are properly allocated +-- and deallocated. +-- +-- +-- CHANGE HISTORY: +-- +-- 12 DEC 93 SAIC Initial PreRelease version +-- 23 JUL 95 SAIC Second PreRelease version +-- 16 OCT 95 SAIC ACVC 2.1 +-- 13 MAR 03 RLB Fixed race condition in test. +-- +--! + +package C940004_0 is +-- Resource_Pkg + + type ID_Type is new Integer range 0..10; + type User_Descriptor_Type is tagged record + Id : ID_Type := 0; + end record; + +end C940004_0; -- Resource_Pkg + +--============================-- +-- no body for C940004_0 +--=============================-- + +with C940004_0; -- Resource_Pkg + +-- This generic package implements a semaphore to control a single resource + +generic + + type Generic_Record_Type is new C940004_0.User_Descriptor_Type + with private; + +package C940004_1 is +-- Generic_Semaphore_Pkg + -- generic package extends the tagged formal generic + -- type with some implementation relevant details, and + -- it provides a semaphore with operations that work + -- on that type + type User_Rec_Type is new Generic_Record_Type with private; + + protected type Semaphore_Type is + function TC_Count return Integer; + entry Request (R : in out User_Rec_Type); + procedure Release (R : in out User_Rec_Type); + private + In_Use : Boolean := false; + end Semaphore_Type; + + function Has_Access (R : User_Rec_Type) return Boolean; + +private + + type User_Rec_Type is new Generic_Record_Type with record + Access_To_Resource : boolean := false; + end record; + +end C940004_1; -- Generic_Semaphore_Pkg + +--===================================================-- + +package body C940004_1 is +-- Generic_Semaphore_Pkg + + protected body Semaphore_Type is + + function TC_Count return Integer is + begin + return Request'Count; + end TC_Count; + + entry Request (R : in out User_Rec_Type) + when not In_Use is + begin + In_Use := true; + R.Access_To_Resource := true; + end Request; + + procedure Release (R : in out User_Rec_Type) is + begin + In_Use := false; + R.Access_To_Resource := false; + end Release; + + end Semaphore_Type; + + function Has_Access (R : User_Rec_Type) return Boolean is + begin + return R.Access_To_Resource; + end Has_Access; + +end C940004_1; -- Generic_Semaphore_Pkg + +--=============================================-- + +with Report; +with C940004_0; -- Resource_Pkg, +with C940004_1; -- Generic_Semaphore_Pkg; + +package C940004_2 is +-- Printer_Mgr_Pkg + + -- Instantiate the generic to get code to manage a single printer; + -- User processes contend for the printer, asking for it by a call + -- to Request, and relinquishing it by a call to Release + + -- This package extends a tagged type to customize it for the printer + -- in question, then it uses the type to instantiate the generic and + -- declare a semaphore specific to the particular resource + + package Resource_Pkg renames C940004_0; + + type User_Desc_Type is new Resource_Pkg.User_Descriptor_Type with record + New_Details : Integer := 0; -- for example + end record; + + package Instantiation is new C940004_1 -- Generic_Semaphore_Pkg + (Generic_Record_Type => User_Desc_Type); + + Printer_Access_Mgr : Instantiation.Semaphore_Type; + + +end C940004_2; -- Printer_Mgr_Pkg + +--============================-- +-- no body for C940004_2 +--============================-- + +with C940004_0; -- Resource_Pkg, +with C940004_2; -- Printer_Mgr_Pkg; + +package C940004_3 is +-- User_Task_Pkg + +-- This package models user tasks that will request and release +-- the printer + package Resource_Pkg renames C940004_0; + package Printer_Mgr_Pkg renames C940004_2; + + task type User_Task_Type (ID : Resource_Pkg.ID_Type) is + entry Get_Printer; -- instructs task to request resource + + entry Release_Printer -- instructs task to release printer + (Descriptor : in out Printer_Mgr_pkg.Instantiation.User_Rec_Type); + + --==================-- + -- Test management machinery + --==================-- + entry TC_Get_Descriptor -- returns descriptor + (Descriptor : out Printer_Mgr_Pkg.Instantiation.User_Rec_Type); + + end User_Task_Type; + + --==================-- + -- Test management machinery + --==================-- + TC_Times_Obtained : Integer := 0; + TC_Times_Released : Integer := 0; + +end C940004_3; -- User_Task_Pkg; + +--==============================================-- + +with Report; +with C940004_0; -- Resource_Pkg, +with C940004_2; -- Printer_Mgr_Pkg, + +package body C940004_3 is +-- User_Task_Pkg + + task body User_Task_Type is + D : Printer_Mgr_Pkg.Instantiation.User_Rec_Type; + begin + D.Id := ID; + ----------------------------------- + Main: + loop + select + accept Get_Printer; + Printer_Mgr_Pkg.Printer_Access_Mgr.Request (D); + -- request resource; if resource is not available, + -- task will be queued to wait + --===================-- + -- Test management machinery + --===================-- + TC_Times_Obtained := TC_Times_Obtained + 1; + -- when request granted, note it and post a message + + or + accept Release_Printer (Descriptor : in out + Printer_Mgr_Pkg.Instantiation.User_Rec_Type) do + + Printer_Mgr_Pkg.Printer_Access_Mgr.Release (D); + -- release the resource, note its release + TC_Times_Released := TC_Times_Released + 1; + Descriptor := D; + end Release_Printer; + exit Main; + + or + accept TC_Get_Descriptor (Descriptor : out + Printer_Mgr_Pkg.Instantiation.User_Rec_Type) do + + Descriptor := D; + end TC_Get_Descriptor; + + end select; + end loop main; + + exception + when others => Report.Failed ("exception raised in User_Task"); + end User_Task_Type; + +end C940004_3; -- User_Task_Pkg; + +--==========================================================-- + +with Report; +with ImpDef; + +with C940004_0; -- Resource_Pkg, +with C940004_2; -- Printer_Mgr_Pkg, +with C940004_3; -- User_Task_Pkg; + +procedure C940004 is + Verbose : constant Boolean := False; + package Resource_Pkg renames C940004_0; + package Printer_Mgr_Pkg renames C940004_2; + package User_Task_Pkg renames C940004_3; + + Task1 : User_Task_Pkg.User_Task_Type (1); + Task2 : User_Task_Pkg.User_Task_Type (2); + Task3 : User_Task_Pkg.User_Task_Type (3); + + User_Rec_1, + User_Rec_2, + User_Rec_3 : Printer_Mgr_Pkg.Instantiation.User_Rec_Type; + +begin + + Report.Test ("C940004", "Check that a protected record can be used to " & + "control access to resources"); + + if (User_Task_Pkg.TC_Times_Obtained /= 0) + or (User_Task_Pkg.TC_Times_Released /= 0) + or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_1) + or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_2) + or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_3) then + Report.Failed ("Wrong initial conditions"); + end if; + + Task1.Get_Printer; -- ask for resource + -- request for resource should be granted + Task1.TC_Get_Descriptor (User_Rec_1);-- wait here 'til task gets resource + + if (User_Task_Pkg.TC_Times_Obtained /= 1) + or (User_Task_Pkg.TC_Times_Released /= 0) + or not Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_1) then + Report.Failed ("Resource not assigned to task 1"); + end if; + + Task2.Get_Printer; -- ask for resource + -- request for resource should be denied + -- and task queued to wait + + -- Task 1 still waiting to accept Release_Printer, still holds resource + -- Task 2 queued on Semaphore.Request + + -- Ensure that Task2 is queued before continuing to make checks and queue + -- Task3. We use a for loop here to avoid hangs in broken implementations. + for TC_Cnt in 1 .. 20 loop + exit when Printer_Mgr_Pkg.Printer_Access_Mgr.TC_Count >= 1; + delay Impdef.Minimum_Task_Switch; + end loop; + + if (User_Task_Pkg.TC_Times_Obtained /= 1) + or (User_Task_Pkg.TC_Times_Released /= 0) then + Report.Failed ("Resource assigned to task 2"); + end if; + + Task3.Get_Printer; -- ask for resource + -- request for resource should be denied + -- and task 3 queued on Semaphore.Request + + Task1.Release_Printer (User_Rec_1);-- task 1 releases resource + -- released resource should be given to + -- queued task 2. + + Task2.TC_Get_Descriptor (User_Rec_2);-- wait here for task 2 + + -- Task 1 has released resource and completed + -- Task 2 has seized the resource + -- Task 3 is queued on Semaphore.Request + + if (User_Task_Pkg.TC_Times_Obtained /= 2) + or (User_Task_Pkg.TC_Times_Released /= 1) + or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_1) + or not Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_2) then + Report.Failed ("Resource not properly released/assigned" & + " to task 2"); + if Verbose then + Report.Comment ("TC_Times_Obtained: " & + Integer'Image (User_Task_Pkg.TC_Times_Obtained)); + Report.Comment ("TC_Times_Released: " & + Integer'Image (User_Task_Pkg.TC_Times_Released)); + Report.Comment ("User 1 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_1))); + Report.Comment ("User 2 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_2))); + end if; + end if; + + Task2.Release_Printer (User_Rec_2);-- task 2 releases resource + + -- task 3 is released from queue, and is given resource + + Task3.TC_Get_Descriptor (User_Rec_3);-- wait for task 3 + + if (User_Task_Pkg.TC_Times_Obtained /= 3) + or (User_Task_Pkg.TC_Times_Released /= 2) + or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_2) + or not Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_3) then + Report.Failed ("Resource not properly released/assigned " & + "to task 3"); + if Verbose then + Report.Comment ("TC_Times_Obtained: " & + Integer'Image (User_Task_Pkg.TC_Times_Obtained)); + Report.Comment ("TC_Times_Released: " & + Integer'Image (User_Task_Pkg.TC_Times_Released)); + Report.Comment ("User 1 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_1))); + Report.Comment ("User 2 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_2))); + Report.Comment ("User 3 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_3))); + end if; + end if; + + Task3.Release_Printer (User_Rec_3);-- task 3 releases resource + + if (User_Task_Pkg.TC_Times_Obtained /=3) + or (User_Task_Pkg.TC_Times_Released /=3) + or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_3) then + Report.Failed ("Resource not properly released by task 3"); + if Verbose then + Report.Comment ("TC_Times_Obtained: " & + Integer'Image (User_Task_Pkg.TC_Times_Obtained)); + Report.Comment ("TC_Times_Released: " & + Integer'Image (User_Task_Pkg.TC_Times_Released)); + Report.Comment ("User 1 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_1))); + Report.Comment ("User 2 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_2))); + Report.Comment ("User 3 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_3))); + end if; + + end if; + + -- Ensure that all tasks have terminated before reporting the result + while not (Task1'terminated + and Task2'terminated + and Task3'terminated) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + +end C940004; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940005.a b/gcc/testsuite/ada/acats/tests/c9/c940005.a new file mode 100644 index 000000000..47a97bf2d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940005.a @@ -0,0 +1,370 @@ +-- C940005.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the body of a protected function can have internal calls +-- to other protected functions and that the body of a protected +-- procedure can have internal calls to protected procedures and to +-- protected functions. +-- +-- TEST DESCRIPTION: +-- Simulate a meter at a freeway on-ramp which, when real-time sensors +-- determine that the freeway is becoming saturated, triggers stop lights +-- which control the access of vehicles to prevent further saturation. +-- Each on-ramp is represented by a protected object - in this case only +-- one is shown (Test_Ramp). The routines to sample and alter the states +-- of the various sensors, to queue the vehicles on the meter and to +-- release them are all part of the protected object and can be shared +-- by various tasks. Apart from the function/procedure tests this example +-- has a mix of other tasking features. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 13 Nov 95 SAIC Updated and fixed bugs ACVC 2.0.1 +-- +--! + + +with Report; +with ImpDef; +with Ada.Calendar; + +procedure C940005 is + +begin + + Report.Test ("C940005", "Check internal calls of protected functions" & + " and procedures"); + + declare -- encapsulate the test + + function "+" (Left : Ada.Calendar.Time; Right: Duration) + return Ada.Calendar.Time renames Ada.Calendar."+"; + + -- Weighted load given to each potential problem area and accumulated + type Load_Factor is range 0..8; + Clear_Level : constant Load_Factor := 0; + Minimum_Level : constant Load_Factor := 1; + Moderate_Level : constant Load_Factor := 2; + Serious_Level : constant Load_Factor := 4; + Critical_Level : constant Load_Factor := 6; + + -- Weighted loads given to each Sample Point (pure weights, not levels) + Local_Overload_wt : constant Load_Factor := 1; + Next_Ramp_in_Overload_wt : constant Load_Factor := 1; + Ramp_Junction_in_Overload_wt : constant Load_Factor :=2; --higher wght + -- :::: other weighted loads + + TC_Multiplier : integer := 1; -- changed half way through + TC_Expected_Passage_Total : constant integer := 486; + + -- This is the time between synchronizing pulses to the ramps. + -- In reality one would expect a time of 5 to 10 seconds. In + -- the interests of speeding up the test suite a shorter time + -- is used + Pulse_Time_Delta : constant duration := ImpDef.Long_Switch_To_New_Task; + + -- control over stopping tasks + protected Control is + procedure Stop_Now; + function Stop return Boolean; + private + Halt : Boolean := False; + end Control; + + protected body Control is + procedure Stop_Now is + begin + Halt := True; + end Stop_Now; + + function Stop return Boolean is + begin + return Halt; + end Stop; + end Control; + + task Pulse_Task; -- task to generate a pulse for each ramp + + -- Carrier task. One is created for each vehicle arriving at the ramp + task type Vehicle; + type acc_Vehicle is access Vehicle; + + --================================================================ + protected Test_Ramp is + function Next_Ramp_in_Overload return Load_Factor; + function Local_Overload return Load_Factor; + function Freeway_Overload return Load_Factor; + function Freeway_Breakdown return Boolean; + function Meter_in_use_State return Boolean; + procedure Set_Local_Overload; + procedure Add_Meter_Queue; + procedure Subtract_Meter_Queue; + procedure Time_Pulse_Received; + entry Wait_at_Meter; + procedure TC_Passage (Pass_Point : Integer); + function TC_Get_Passage_Total return integer; + -- ::::::::: many routines are not shown (for example none of the + -- clears, none of the real-time-sensor handlers) + + private + + Release_One_Vehicle : Boolean := false; + Meter_in_Use : Boolean := false; + Fwy_Break_State : Boolean := false; + + + Ramp_Count : integer range 0..20 := 0; + Ramp_Count_Threshold : integer := 15; + + -- Current state of the various Sample Points + Local_State : Load_Factor := Clear_Level; + Next_Ramp_State : Load_Factor := Clear_Level; + -- :::: other Sample Point states not shown + + TC_Passage_Total : integer := 0; + end Test_Ramp; + --================================================================ + protected body Test_Ramp is + + procedure Start_Meter is + begin + Meter_in_Use := True; + null; -- stub :::: trigger the metering hardware + end Start_Meter; + + -- External call for Meter_in_Use + function Meter_in_Use_State return Boolean is + begin + return Meter_in_Use; + end Meter_in_Use_State; + + -- Trace the paths through the various routines by totaling the + -- weighted call parameters + procedure TC_Passage (Pass_Point : Integer) is + begin + TC_Passage_Total := TC_Passage_Total+(Pass_Point*TC_Multiplier); + end TC_Passage; + + -- For the final check of the whole test + function TC_Get_Passage_Total return integer is + begin + return TC_Passage_Total; + end TC_Get_Passage_Total; + + -- These Set/Clear routines are triggered by real-time sensors that + -- reflect traffic state + procedure Set_Local_Overload is + begin + Local_State := Local_Overload_wt; + if not Meter_in_Use then + Start_Meter; -- LOCAL INTERNAL PROCEDURE FROM PROCEDURE + end if; + end Set_Local_Overload; + + --::::: Set/Clear routines for all the other sensors not shown + + function Local_Overload return Load_Factor is + begin + return Local_State; + end Local_Overload; + + function Next_Ramp_in_Overload return Load_Factor is + begin + return Next_Ramp_State; + end Next_Ramp_in_Overload; + + -- :::::::: other overload factor states not shown + + -- return the summation of all the load factors + function Freeway_Overload return Load_Factor is + begin + return Local_Overload -- EACH IS A CALL OF A + -- + :::: others -- FUNCTION FROM WITHIN + + Next_Ramp_in_Overload; -- A FUNCTION + end Freeway_Overload; + + -- Freeway Breakdown is defined as traffic moving < 5mph + function Freeway_Breakdown return Boolean is + begin + return Fwy_Break_State; + end Freeway_Breakdown; + + -- Keep count of vehicles currently on meter queue - we can't use + -- the 'count because we need the outcall trigger + procedure Add_Meter_Queue is + TC_Pass_Point : constant integer := 22; + begin + Ramp_Count := Ramp_Count + 1; + TC_Passage ( TC_Pass_Point ); -- note passage through here + if Ramp_Count > Ramp_Count_Threshold then + null; -- :::: stub, trigger surface street notification + end if; + end Add_Meter_Queue; + -- + procedure Subtract_Meter_Queue is + TC_Pass_Point : constant integer := 24; + begin + Ramp_Count := Ramp_Count - 1; + TC_Passage ( TC_Pass_Point ); -- note passage through here + end Subtract_Meter_Queue; + + -- Here each Vehicle task queues itself awaiting release + entry Wait_at_Meter when Release_One_Vehicle is + -- EXAMPLE OF ENTRY WITH BARRIERS AND PERSISTENT SIGNAL + TC_Pass_Point : constant integer := 23; + begin + TC_Passage ( TC_Pass_Point ); -- note passage through here + Release_One_Vehicle := false; -- Consume the signal + -- Decrement number of vehicles on ramp + Subtract_Meter_Queue; -- CALL PROCEDURE FROM WITHIN ENTRY BODY + end Wait_at_Meter; + + + procedure Time_Pulse_Received is + Load : Load_factor := Freeway_Overload; -- CALL MULTILEVEL + -- FUNCTION + -- FROM WITHIN PROCEDURE + begin + -- if broken down, no vehicles are released + if not Freeway_Breakdown then -- CALL FUNCTION FROM A PROCEDURE + if Load < Moderate_Level then + Release_One_Vehicle := true; + end if; + null; -- stub ::: If other levels, release every other + -- pulse, every third pulse etc. + end if; + end Time_Pulse_Received; + + end Test_Ramp; + --================================================================ + + + -- Simulate the arrival of a vehicle at the Ramp_Receiver and the + -- generation of an accompanying carrier task + procedure New_Arrival is + Next_Vehicle_Task: acc_Vehicle := new Vehicle; + TC_Pass_Point : constant integer := 3; + begin + Test_Ramp.TC_Passage ( TC_Pass_Point ); -- Note passage through here + null; + end New_arrival; + + + -- Carrier task. One is created for each vehicle arriving at the ramp + task body Vehicle is + TC_Pass_point : constant integer := 1; + TC_Pass_Point_2 : constant integer := 21; + TC_Pass_Point_3 : constant integer := 2; + begin + Test_Ramp.TC_Passage ( TC_Pass_Point ); -- note passage through here + if Test_Ramp.Meter_in_Use_State then + Test_Ramp.TC_Passage ( TC_Pass_Point_2 ); -- note passage + -- Increment count of number of vehicles on ramp + Test_Ramp.Add_Meter_Queue; -- CALL a protected PROCEDURE + -- which is also called from within + -- enter the meter queue + Test_Ramp.Wait_at_Meter; -- CALL a protected ENTRY + end if; + Test_Ramp.TC_Passage ( TC_Pass_Point_3 ); -- note passage thru here + null; --:::: call to the first in the series of the Ramp_Sensors + -- this "passes" the vehicle from one sensor to the next + exception + when others => + Report.Failed ("Unexpected exception in Vehicle Task"); + end Vehicle; + + + -- Task transmits a synchronizing "pulse" to all ramps + -- + task body Pulse_Task is + Pulse_Time : Ada.Calendar.Time := Ada.Calendar.Clock; + begin + While not Control.Stop loop + delay until Pulse_Time; + Test_Ramp.Time_Pulse_Received; -- causes INTERNAL CALLS + -- :::::::::: and to all the others + Pulse_Time := Pulse_Time + Pulse_Time_Delta; -- calculate next + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Pulse_Task"); + end Pulse_Task; + + + begin -- declare + + -- Test driver. This is ALL test control code + + -- First simulate calls to the protected functions and procedures + -- from without the protected object + -- + -- CALL FUNCTIONS + if Test_Ramp.Local_Overload /= Clear_Level then + Report.Failed ("External Call to Local_Overload incorrect"); + end if; + if Test_Ramp.Next_Ramp_in_Overload /= Clear_Level then + Report.Failed ("External Call to Next_Ramp_in_Overload incorrect"); + end if; + if Test_Ramp.Freeway_Overload /= Clear_Level then + Report.Failed ("External Call to Freeway_Overload incorrect"); + end if; + + -- Now Simulate the arrival of a vehicle to verify path through test + New_Arrival; + delay Pulse_Time_Delta*2; -- allow it to pass through the complex + + TC_Multiplier := 5; -- change the weights for the paths for the next + -- part of the test + + -- Simulate a real-time sensor reporting overload + Test_Ramp.Set_Local_Overload; -- CALL A PROCEDURE (and change levels) + + -- CALL FUNCTIONS again + if Test_Ramp.Local_Overload /= Minimum_Level then + Report.Failed ("External Call to Local_Overload incorrect - 2"); + end if; + if Test_Ramp.Freeway_Overload /= Minimum_Level then + Report.Failed ("External Call to Freeway_Overload incorrect -2"); + end if; + + -- Now Simulate the arrival of another vehicle again causing + -- INTERNAL CALLS but following different paths (queuing on the + -- meter etc.) + New_Arrival; + delay Pulse_Time_Delta*2; -- allow it to pass through the complex + + Control.Stop_Now; -- finish test + + if TC_Expected_Passage_Total /= Test_Ramp.TC_Get_Passage_Total then + Report.Failed ("Unexpected paths taken"); + end if; + + end; -- declare + + Report.Result; + +end C940005; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940006.a b/gcc/testsuite/ada/acats/tests/c9/c940006.a new file mode 100644 index 000000000..36e6c9171 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940006.a @@ -0,0 +1,223 @@ +-- C940006.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the body of a protected function can have external calls +-- to other protected functions and that the body of a protected +-- procedure can have external calls to protected procedures and to +-- protected functions. +-- +-- TEST DESCRIPTION: +-- Use a subset of the simulation of the freeway on-ramp described in +-- c940005. In this case two protected objects are used but only a +-- minimum of routines are shown in each. Both objects are hard coded +-- and detail two adjacent on-ramps (Ramp_31 & Ramp_32) with routines in +-- each which use external calls to the other. + +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; + +procedure C940006 is + +begin + + Report.Test ("C940006", "Check external calls of protected functions" & + " and procedures"); + + declare -- encapsulate the test + + -- Weighted load given to each potential problem area and accumulated + type Load_Factor is range 0..8; + -- + Clear_Level : constant Load_Factor := 0; + Minimum_Level : constant Load_Factor := 1; + Moderate_Level : constant Load_Factor := 3; + Serious_Level : constant Load_Factor := 4; + Critical_Level : constant Load_Factor := 6; + + --================================================================ + -- Only the Routines that are used in this test are shown + -- + protected Ramp_31 is + + function Local_Overload return Load_Factor; + procedure Set_Local_Overload(Sensor_Level : Load_Factor); + procedure Notify; + function Next_Ramp_Overload return Load_Factor; + function Freeway_Overload return Load_Factor; + procedure Downstream_Ramps; + function Get_DSR_Accumulate return Load_Factor; + + private + Next_Ramp_Alert : Boolean := false; -- Next Ramp is in trouble? + + -- Current state of the various Sample Points + Local_State : Load_Factor := Clear_Level; + -- Accumulated load for next three downstream ramps + DSR_Accumulate : Load_Factor := Clear_Level; + + end Ramp_31; + --================================================================ + -- Only the Routines that are used in this test are shown + -- + protected Ramp_32 is + + function Local_Overload return Load_Factor; + procedure Set_Local_Overload (Sensor_Level : Load_Factor); + + private + + Local_State : Load_Factor := Clear_Level; + + end Ramp_32; + --================================================================ + protected body Ramp_31 is + + -- These Set/Clear routines are triggered by real-time sensors that + -- reflect traffic state + procedure Set_Local_Overload (Sensor_Level : Load_Factor) is + begin + -- Notify "previous" ramp to check this one for current state. + -- Subsequent changes in state will not send an alert + null; --::::: (see Ramp_32 for this code) + Local_State := Sensor_Level; + null; --::::: Start local meter if not already started + end Set_Local_Overload; + + function Local_Overload return Load_Factor is + begin + return Local_State; + end Local_Overload; + + -- This is notification from the next ramp that it is in + -- overload. With this provision we only need to sample the next + -- ramp during adverse conditions. + procedure Notify is + begin + Next_Ramp_Alert := true; + end Notify; + + function Next_Ramp_Overload return Load_Factor is + begin + if Next_Ramp_Alert then + -- EXTERNAL FUNCTION CALL FROM FUNCTION + -- Get next ramp's current state + return Ramp_32.Local_Overload; + else + return Clear_Level; + end if; + end Next_Ramp_Overload; + + -- return the summation of all the load factors + function Freeway_Overload return Load_Factor is + begin + return Local_Overload + -- + :::: others + + Next_Ramp_Overload; + end Freeway_Overload; + + -- Snapshot the states of the next three downstream ramps + procedure Downstream_Ramps is + begin + DSR_Accumulate := Ramp_32.Local_Overload; -- EXTERNAL FUNCTION + -- :::: + Ramp_33.Local_Overload -- FROM PROCEDURE + -- :::: + Ramp_34.Local_Overload + end Downstream_Ramps; + + -- Get last snapshot + function Get_DSR_Accumulate return Load_Factor is + begin + return DSR_Accumulate; + end Get_DSR_Accumulate; + + end Ramp_31; + --================================================================ + protected body Ramp_32 is + + function Local_Overload return Load_Factor is + begin + return Local_State; + end; + + + -- These Set/Clear routines are triggered by real-time sensors that + -- reflect traffic state + procedure Set_Local_Overload(Sensor_Level : Load_Factor) is + begin + if Local_State = Clear_Level then + -- Notify "previous" ramp to check this one for current state. + -- Subsequent changes in state will not send an alert + -- When the situation clears another routine performs the + -- all_clear notification. (not shown) + -- EXTERNAL CALL OF PROCEDURE FROM PROCEDURE + Ramp_31.Notify; + end if; + Local_State := Sensor_Level; + null; --::::: Start local meter if not already started + end; + + end Ramp_32; + --================================================================ + + + + begin -- declare + + -- Test driver. This is ALL test control code + -- Simulate calls to the protected functions and procedures + -- from without the protected object, these will, in turn make the + -- external calls. + + -- Check initial conditions, exercising the simple calls + if not (Ramp_31.Local_Overload = Clear_Level and + Ramp_31.Next_Ramp_Overload = Clear_Level and + Ramp_31.Freeway_Overload = Clear_Level) and + Ramp_32.Local_Overload = Clear_Level then + Report.Failed ("Initial Calls provided unexpected Results"); + end if; + + -- Simulate real-time sensors reporting overloads at a hardware level + Ramp_31.Set_Local_Overload (1); + Ramp_32.Set_Local_Overload (3); + + Ramp_31.Downstream_Ramps; -- take the current snapshot + + if not (Ramp_31.Local_Overload = Minimum_Level and + Ramp_31.Get_DSR_Accumulate = Moderate_Level and + Ramp_31.Freeway_Overload = Serious_Level) then + Report.Failed ("Secondary Calls provided unexpected Results"); + end if; + + end; -- declare + + Report.Result; + +end C940006; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940007.a b/gcc/testsuite/ada/acats/tests/c9/c940007.a new file mode 100644 index 000000000..41e80f4e2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940007.a @@ -0,0 +1,427 @@ +-- C940007.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the body of a protected function declared as an object of a +-- given type can have internal calls to other protected functions and +-- that a protected procedure in such an object can have internal calls +-- to protected procedures and to protected functions. +-- +-- TEST DESCRIPTION: +-- Simulate a meter at a freeway on-ramp which, when real-time sensors +-- determine that the freeway is becoming saturated, triggers stop lights +-- which control the access of vehicles to prevent further saturation. +-- Each on-ramp is represented by a protected object of the type Ramp. +-- The routines to sample and alter the states of the various sensors, to +-- queue the vehicles on the meter and to release them are all part of +-- the protected object and can be shared by various tasks. Apart from +-- the function/procedure tests this example has a mix of other tasking +-- features. In this test two objects representing two adjacent ramps +-- are created from the same type. The same "traffic" is simulated for +-- each ramp. The results should be identical. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 13 Nov 95 SAIC Replaced shared global variable Pulse_Stop +-- with a protected object. +-- ACVC 2.0.1 +-- +--! + + +with Report; +with ImpDef; +with Ada.Calendar; + + +procedure C940007 is + +begin + + Report.Test ("C940007", "Check internal calls of protected functions" & + " and procedures in objects declared as a type"); + + declare -- encapsulate the test + + function "+" (Left : Ada.Calendar.Time; Right: Duration) + return Ada.Calendar.Time renames Ada.Calendar."+"; + + -- Weighted load given to each potential problem area and accumulated + type Load_Factor is range 0..8; + Clear_Level : constant Load_Factor := 0; + Minimum_Level : constant Load_Factor := 1; + Moderate_Level : constant Load_Factor := 2; + Serious_Level : constant Load_Factor := 4; + Critical_Level : constant Load_Factor := 6; + + -- Weighted loads given to each Sample Point (pure weights, not levels) + Local_Overload_wt : constant Load_Factor := 1; + Next_Ramp_in_Overload_wt : constant Load_Factor := 1; + Ramp_Junction_in_Overload_wt : constant Load_Factor :=2; --higher wght + -- :::: other weighted loads + + TC_Expected_Passage_Total : integer := 486; + + + -- This is the time between synchronizing pulses to the ramps. + -- In reality one would expect a time of 5 to 10 seconds. In + -- the interests of speeding up the test suite a shorter time + -- is used + Pulse_Time_Delta : constant duration := ImpDef.Long_Switch_To_New_Task; + + + -- control over stopping tasks + protected Control is + procedure Stop_Now; + function Stop return Boolean; + private + Halt : Boolean := False; + end Control; + + protected body Control is + procedure Stop_Now is + begin + Halt := True; + end Stop_Now; + + function Stop return Boolean is + begin + return Halt; + end Stop; + end Control; + + + task Pulse_Task; -- task to generate a pulse for each ramp + + -- Carrier tasks. One is created for each vehicle arriving at each ramp + task type Vehicle_31; -- For Ramp_31 + type acc_Vehicle_31 is access Vehicle_31; + -- + task type Vehicle_32; -- For Ramp_32 + type acc_Vehicle_32 is access Vehicle_32; + + --================================================================ + protected type Ramp is + function Next_Ramp_in_Overload return Load_Factor; + function Local_Overload return Load_Factor; + function Freeway_Overload return Load_Factor; + function Freeway_Breakdown return Boolean; + function Meter_in_Use_State return Boolean; + procedure Set_Local_Overload; + procedure Add_Meter_Queue; + procedure Subtract_Meter_Queue; + procedure Time_Pulse_Received; + entry Wait_at_Meter; + procedure TC_Passage (Pass_Point : Integer); + function TC_Get_Passage_Total return integer; + -- ::::::::: many routines are not shown (for example none of the + -- clears, none of the real-time-sensor handlers) + + private + + Release_One_Vehicle : Boolean := false; + Meter_in_Use : Boolean := false; + Fwy_Break_State : Boolean := false; + + + Ramp_Count : integer range 0..20 := 0; + Ramp_Count_Threshold : integer := 15; + + -- Current state of the various Sample Points + Local_State : Load_Factor := Clear_Level; + Next_Ramp_State : Load_Factor := Clear_Level; + -- :::: other Sample Point states not shown + + TC_Multiplier : integer := 1; -- changed half way through + TC_Passage_Total : integer := 0; + end Ramp; + --================================================================ + protected body Ramp is + + procedure Start_Meter is + begin + Meter_in_Use := True; + null; -- stub :::: trigger the metering hardware + end Start_Meter; + + function Meter_in_Use_State return Boolean is + begin + return Meter_in_Use; + end Meter_in_Use_State; + + -- Trace the paths through the various routines by totaling the + -- weighted call parameters + procedure TC_Passage (Pass_Point : Integer) is + begin + TC_Passage_Total := TC_Passage_Total+(Pass_Point*TC_Multiplier); + end TC_Passage; + + -- For the final check of the whole test + function TC_Get_Passage_Total return integer is + begin + return TC_Passage_Total; + end TC_Get_Passage_Total; + + -- These Set/Clear routines are triggered by real-time sensors that + -- reflect traffic state + procedure Set_Local_Overload is + begin + Local_State := Local_Overload_wt; + if not Meter_in_Use then + Start_Meter; -- LOCAL INTERNAL PROCEDURE FROM PROCEDURE + end if; + -- Change the weights for the paths for the next part of the test + TC_Multiplier :=5; + end Set_Local_Overload; + + --::::: Set/Clear routines for all the other sensors not shown + + function Local_Overload return Load_Factor is + begin + return Local_State; + end Local_Overload; + + function Next_Ramp_in_Overload return Load_Factor is + begin + return Next_Ramp_State; + end Next_Ramp_in_Overload; + + -- :::::::: other overload factor states not shown + + -- return the summation of all the load factors + function Freeway_Overload return Load_Factor is + begin + return Local_Overload -- EACH IS A CALL OF A + -- + :::: others -- FUNCTION FROM WITHIN + + Next_Ramp_in_Overload; -- A FUNCTION + end Freeway_Overload; + + -- Freeway Breakdown is defined as traffic moving < 5mph + function Freeway_Breakdown return Boolean is + begin + return Fwy_Break_State; + end Freeway_Breakdown; + + -- Keep count of vehicles currently on meter queue - we can't use + -- the 'count because we need the outcall trigger + procedure Add_Meter_Queue is + TC_Pass_Point : constant integer := 22; + begin + Ramp_Count := Ramp_Count + 1; + TC_Passage ( TC_Pass_Point ); -- note passage through here + if Ramp_Count > Ramp_Count_Threshold then + null; -- :::: stub, trigger surface street notification + end if; + end Add_Meter_Queue; + -- + procedure Subtract_Meter_Queue is + TC_Pass_Point : constant integer := 24; + begin + Ramp_Count := Ramp_Count - 1; + TC_Passage ( TC_Pass_Point ); -- note passage through here + end Subtract_Meter_Queue; + + -- Here each Vehicle task queues itself awaiting release + entry Wait_at_Meter when Release_One_Vehicle is + -- EXAMPLE OF ENTRY WITH BARRIERS AND PERSISTENT SIGNAL + TC_Pass_Point : constant integer := 23; + begin + TC_Passage ( TC_Pass_Point ); -- note passage through here + Release_One_Vehicle := false; -- Consume the signal + -- Decrement number of vehicles on ramp + Subtract_Meter_Queue; -- CALL PROCEDURE FROM WITHIN ENTRY BODY + end Wait_at_Meter; + + + procedure Time_Pulse_Received is + Load : Load_factor := Freeway_Overload; -- CALL MULTILEVEL FUNCTN + -- FROM WITHIN PROCEDURE + begin + -- if broken down, no vehicles are released + if not Freeway_Breakdown then -- CALL FUNCTION FROM A PROCEDURE + if Load < Moderate_Level then + Release_One_Vehicle := true; + end if; + null; -- stub ::: If other levels, release every other + -- pulse, every third pulse etc. + end if; + end Time_Pulse_Received; + + end Ramp; + --================================================================ + + -- Now create two Ramp objects from this type + Ramp_31 : Ramp; + Ramp_32 : Ramp; + + + + -- Simulate the arrival of a vehicle at the Ramp_Receiver of Ramp_31 + -- and the generation of an accompanying carrier task + procedure New_Arrival_31 is + Next_Vehicle_Task_31: acc_Vehicle_31 := new Vehicle_31; + TC_Pass_Point : constant integer := 3; + begin + Ramp_31.TC_Passage ( TC_Pass_Point ); -- Note passage through here + null; --::: stub + end New_arrival_31; + + + -- Carrier task. One is created for each vehicle arriving at Ramp_31 + task body Vehicle_31 is + TC_Pass_point : constant integer := 1; + TC_Pass_Point_2 : constant integer := 21; + TC_Pass_Point_3 : constant integer := 2; + begin + Ramp_31.TC_Passage ( TC_Pass_Point ); -- note passage through here + if Ramp_31.Meter_in_Use_State then + Ramp_31.TC_Passage ( TC_Pass_Point_2 ); -- note passage + -- Increment count of number of vehicles on ramp + Ramp_31.Add_Meter_Queue; -- CALL a protected PROCEDURE + -- which is also called from within + -- enter the meter queue + Ramp_31.Wait_at_Meter; -- CALL a protected ENTRY + end if; + Ramp_31.TC_Passage ( TC_Pass_Point_3 ); -- note passage through here + null; --:::: call to the first in the series of the Ramp_Sensors + -- this "passes" the vehicle from one sensor to the next + exception + when others => + Report.Failed ("Unexpected exception in Vehicle Task"); + end Vehicle_31; + + + -- Simulate the arrival of a vehicle at the Ramp_Receiver and the + -- generation of an accompanying carrier task + procedure New_Arrival_32 is + Next_Vehicle_Task_32 : acc_Vehicle_32 := new Vehicle_32; + TC_Pass_Point : constant integer := 3; + begin + Ramp_32.TC_Passage ( TC_Pass_Point ); -- Note passage through here + null; --::: stub + end New_arrival_32; + + + -- Carrier task. One is created for each vehicle arriving at Ramp_32 + task body Vehicle_32 is + TC_Pass_point : constant integer := 1; + TC_Pass_Point_2 : constant integer := 21; + TC_Pass_Point_3 : constant integer := 2; + begin + Ramp_32.TC_Passage ( TC_Pass_Point ); -- note passage through here + if Ramp_32.Meter_in_Use_State then + Ramp_32.TC_Passage ( TC_Pass_Point_2 ); -- note passage + -- Increment count of number of vehicles on ramp + Ramp_32.Add_Meter_Queue; -- CALL a protected PROCEDURE + -- which is also called from within + -- enter the meter queue + Ramp_32.Wait_at_Meter; -- CALL a protected ENTRY + end if; + Ramp_32.TC_Passage ( TC_Pass_Point_3 ); -- note passage through here + null; --:::: call to the first in the series of the Ramp_Sensors + -- this "passes" the vehicle from one sensor to the next + exception + when others => + Report.Failed ("Unexpected exception in Vehicle Task"); + end Vehicle_32; + + + -- Task transmits a synchronizing "pulse" to all ramps + -- + task body Pulse_Task is + Pulse_Time : Ada.Calendar.Time := Ada.Calendar.Clock; + begin + While not Control.Stop loop + delay until Pulse_Time; + Ramp_31.Time_Pulse_Received; -- CALL OF PROCEDURE CAUSES + Ramp_32.Time_Pulse_Received; -- INTERNAL CALLS + -- :::::::::: and to all the others + Pulse_Time := Pulse_Time + Pulse_Time_Delta; -- calculate next + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Pulse_Task"); + end Pulse_Task; + + + begin -- declare + + -- Test driver. This is ALL test control code + + -- First simulate calls to the protected functions and procedures + -- from without the protected object + -- + -- CALL FUNCTIONS + if not ( Ramp_31.Local_Overload = Clear_Level and + Ramp_31.Next_Ramp_in_Overload = Clear_Level and + Ramp_31.Freeway_Overload = Clear_Level ) then + Report.Failed ("Initial Calls to Ramp_31 incorrect"); + end if; + if not ( Ramp_32.Local_Overload = Clear_Level and + Ramp_32.Next_Ramp_in_Overload = Clear_Level and + Ramp_32.Freeway_Overload = Clear_Level ) then + Report.Failed ("Initial Calls to Ramp_32 incorrect"); + end if; + + -- Now Simulate the arrival of a vehicle at each ramp to verify + -- basic paths through the test + New_Arrival_31; + New_Arrival_32; + delay Pulse_Time_Delta*2; -- allow them to pass through the complex + + -- Simulate real-time sensors reporting overload + Ramp_31.Set_Local_Overload; -- CALL A PROCEDURE (and change levels) + Ramp_32.Set_Local_Overload; -- CALL A PROCEDURE (and change levels) + + -- CALL FUNCTIONS again + if not ( Ramp_31.Local_Overload = Minimum_Level and + Ramp_31.Freeway_Overload = Minimum_Level ) then + Report.Failed ("Secondary Calls to Ramp_31 incorrect"); + end if; + if not ( Ramp_32.Local_Overload = Minimum_Level and + Ramp_32.Freeway_Overload = Minimum_Level ) then + Report.Failed ("Secondary Calls to Ramp_32 incorrect"); + end if; + + -- Now Simulate the arrival of another vehicle at each ramp again causing + -- INTERNAL CALLS but following different paths (queuing on the + -- meter etc.) + New_Arrival_31; + New_Arrival_32; + delay Pulse_Time_Delta*2; -- allow them to pass through the complex + + Control.Stop_Now; -- finish test + + if not (TC_Expected_Passage_Total = Ramp_31.TC_Get_Passage_Total and + TC_Expected_Passage_Total = Ramp_32.TC_Get_Passage_Total) then + Report.Failed ("Unexpected paths taken"); + end if; + + end; -- declare + + Report.Result; + +end C940007; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940010.a b/gcc/testsuite/ada/acats/tests/c9/c940010.a new file mode 100644 index 000000000..c4a670552 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940010.a @@ -0,0 +1,269 @@ +-- C940010.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that if an exception is raised during the execution of an +-- entry body it is propagated back to the caller +-- +-- TEST DESCRIPTION: +-- Use a small fragment of code from the simulation of a freeway meter +-- used in c940007. Create three individual tasks which will be queued on +-- the entry as the barrier is set. Release them one at a time. A +-- procedure which is called within the entry has been modified for this +-- test to raise a different exception for each pass through. Check that +-- all expected exceptions are raised and propagated. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +with Report; +with ImpDef; + +procedure C940010 is + + TC_Failed_1 : Boolean := false; + +begin + + Report.Test ("C940010", "Check that an exception raised in an entry " & + "body is propagated back to the caller"); + + declare -- encapsulate the test + + TC_Defined_Error : Exception; -- User defined exception + TC_Expected_Passage_Total : constant integer := 669; + TC_Int : constant integer := 5; + + -- Carrier tasks. One is created for each vehicle arriving at each ramp + task type Vehicle_31; -- For Ramp_31 + type acc_Vehicle_31 is access Vehicle_31; + + + --================================================================ + protected Ramp_31 is + + function Meter_in_Use_State return Boolean; + procedure Add_Meter_Queue; + procedure Subtract_Meter_Queue; + entry Wait_at_Meter; + procedure Pulse; + -- + procedure TC_Passage (Pass_Point : Integer); + function TC_Get_Passage_Total return integer; + function TC_Get_Current_Exception return integer; + + private + + Release_One_Vehicle : Boolean := false; + Meter_in_Use : Boolean := true; -- TC: set true for this test + -- + TC_Multiplier : integer := 1; + TC_Passage_Total : integer := 0; + -- Use this to cycle through the required exceptions + TC_Current_Exception : integer range 0..3 := 0; + + end Ramp_31; + --================================================================ + protected body Ramp_31 is + + + -- Trace the paths through the various routines by totaling the + -- weighted call parameters + procedure TC_Passage (Pass_Point : Integer) is + begin + TC_Passage_Total := TC_Passage_Total+(Pass_Point*TC_Multiplier); + end TC_Passage; + + -- For the final check of the whole test + function TC_Get_Passage_Total return integer is + begin + return TC_Passage_Total; + end TC_Get_Passage_Total; + + function TC_Get_Current_Exception return integer is + begin + return TC_Current_Exception; + end TC_Get_Current_Exception; + + + ----------------- + + function Meter_in_Use_State return Boolean is + begin + return Meter_in_Use; + end Meter_in_Use_State; + + -- Simulate the effects of the regular signal pulse + procedure Pulse is + begin + Release_one_Vehicle := true; + end Pulse; + + -- Keep count of vehicles currently on meter queue - we can't use + -- the 'count because we need the outcall trigger + procedure Add_Meter_Queue is + begin + null; --::: stub + end Add_Meter_Queue; + + -- TC: This routine has been modified to raise the required + -- exceptions + procedure Subtract_Meter_Queue is + TC_Pass_Point1 : constant integer := 10; + TC_Pass_Point2 : constant integer := 20; + TC_Pass_Point3 : constant integer := 30; + TC_Pass_Point9 : constant integer := 1000; -- error + begin + -- Cycle through the required exceptions, one per call + TC_Current_Exception := TC_Current_Exception + 1; + case TC_Current_Exception is + when 1 => + TC_Passage (TC_Pass_Point1); -- note passage through here + raise Storage_Error; -- PREDEFINED EXCEPTION + when 2 => + TC_Passage (TC_Pass_Point2); -- note passage through here + raise TC_Defined_Error; -- USER DEFINED EXCEPTION + when 3 => + TC_Passage (TC_Pass_Point3); -- note passage through here + -- RUN TIME EXCEPTION (Constraint_Error) + -- Add the value 3 to 5 then try to assign it to an object + -- whose range is 0..3 - this causes the exception. + -- Disguise the values which cause the Constraint_Error + -- so that the optimizer will not eliminate this code + -- Note: the variable is checked at the end to ensure + -- that the actual assignment is attempted. Also note + -- the value remains at 3 as the assignment does not + -- take place. This is the value that is checked at + -- the end of the test. + -- Otherwise the optimizer could decide that the result + -- of the assignment was not used so why bother to do it? + TC_Current_Exception := + Report.Ident_Int (TC_Current_Exception) + + Report.Ident_Int (TC_Int); + when others => + -- Set flag for Report.Failed which cannot be called from + -- within a Protected Object + TC_Failed_1 := True; + end case; + + TC_Passage ( TC_Pass_Point9 ); -- note passage through here + end Subtract_Meter_Queue; + + -- Here each Vehicle task queues itself awaiting release + entry Wait_at_Meter when Release_One_Vehicle is + -- Example of entry with barriers and persistent signal + TC_Pass_Point : constant integer := 2; + begin + TC_Passage ( TC_Pass_Point ); -- note passage through here + Release_One_Vehicle := false; -- Consume the signal + -- Decrement number of vehicles on ramp + Subtract_Meter_Queue; -- Call procedure from within entry body + end Wait_at_Meter; + + end Ramp_31; + --================================================================ + + -- Carrier task. One is created for each vehicle arriving at Ramp_31 + task body Vehicle_31 is + TC_Pass_Point_1 : constant integer := 100; + TC_Pass_Point_2 : constant integer := 200; + TC_Pass_Point_3 : constant integer := 300; + begin + if Ramp_31.Meter_in_Use_State then + -- Increment count of number of vehicles on ramp + Ramp_31.Add_Meter_Queue; -- Call a protected procedure + -- which is also called from within + -- enter the meter queue + Ramp_31.Wait_at_Meter; -- Call a protected entry + Report.Failed ("Exception not propagated back"); + end if; + null; --:::: call to the first in the series of the Ramp_Sensors + -- this "passes" the vehicle from one sensor to the next + exception + when Storage_Error => + Ramp_31.TC_Passage ( TC_Pass_Point_1 ); -- note passage + when TC_Defined_Error => + Ramp_31.TC_Passage ( TC_Pass_Point_2 ); -- note passage + when Constraint_Error => + Ramp_31.TC_Passage ( TC_Pass_Point_3 ); -- note passage + when others => + Report.Failed ("Unexpected exception in Vehicle Task"); + end Vehicle_31; + + -- Simulate the arrival of a vehicle at the Ramp_Receiver of Ramp_31 + -- and the generation of an accompanying carrier task + procedure New_Arrival_31 is + Next_Vehicle_Task_31: acc_Vehicle_31 := new Vehicle_31; + TC_Pass_Point : constant integer := 1; + begin + Ramp_31.TC_Passage ( TC_Pass_Point ); -- Note passage through here + null; --::: stub + end New_arrival_31; + + + + begin -- declare + + -- Test driver. This is ALL test control code + + -- Create three independent tasks which will queue themselves on the + -- entry. Each task will get a different exception + New_Arrival_31; + New_Arrival_31; + New_Arrival_31; + + delay ImpDef.Clear_Ready_Queue; + + -- Set the barrier condition of the entry true, releasing one task + Ramp_31.Pulse; + delay ImpDef.Clear_Ready_Queue; + + Ramp_31.Pulse; + delay ImpDef.Clear_Ready_Queue; + + Ramp_31.Pulse; + delay ImpDef.Clear_Ready_Queue; + + if (TC_Expected_Passage_Total /= Ramp_31.TC_Get_Passage_Total) or + -- Note: We are not really interested in this next check. It is + -- here to ensure the earlier statements which raised the + -- Constraint_Error are not optimized out + (Ramp_31.TC_Get_Current_Exception /= 3) then + Report.Failed ("Unexpected paths taken"); + end if; + + end; -- declare + + if TC_Failed_1 then + Report.Failed ("Bad path through Subtract_Meter_Queue"); + end if; + + Report.Result; + +end C940010; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940011.a b/gcc/testsuite/ada/acats/tests/c9/c940011.a new file mode 100644 index 000000000..65228666c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940011.a @@ -0,0 +1,175 @@ +-- C940011.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that, in the body of a protected object created by the execution +-- of an allocator, external calls to other protected objects via +-- the access type are correctly performed +-- +-- TEST DESCRIPTION: +-- Use a subset of the simulation of the freeway on-ramp described in +-- c940005. In this case an array of access types is built with pointers +-- to successive ramps. The external calls within the protected +-- objects are made via the index into the array. Routines which refer +-- to the "previous" ramp and the "next" ramp are exercised. (Note: The +-- first and last ramps are assumed to be dummies and no first/last +-- condition code is included) +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +with Report; + + +procedure C940011 is + + type Ramp; + type acc_Ramp is access Ramp; + + subtype Ramp_Index is integer range 1..4; + + + -- Weighted load given to each potential problem area and accumulated + type Load_Factor is range 0..8; + Clear_Level : constant Load_Factor := 0; + Moderate_Level : constant Load_Factor := 3; + + --================================================================ + -- Only the Routines that are used in this test are shown + -- + protected type Ramp is + + procedure Set_Index (Index : Ramp_Index); + procedure Set_Local_Overload (Sensor_Level : Load_Factor); + function Local_Overload return Load_Factor; + procedure Notify; + function Next_Ramp_Overload return Load_Factor; + + private + + This_Ramp : Ramp_Index; + + Next_Ramp_Alert : Boolean := false; -- Next Ramp is in trouble? + + -- Current state of the various Sample Points + Local_State : Load_Factor := Clear_Level; + + end Ramp; + --================================================================ + + -- Build a set of Ramp objects and an array of pointers to them + -- + Ramp_Array : array (Ramp_Index) of acc_Ramp := (Ramp_Index => new Ramp); + + --================================================================ + protected body Ramp is + + procedure Set_Index (Index : Ramp_Index) is + begin + This_Ramp := Index; + end Set_Index; + + -- These Set/Clear routines are triggered by real-time sensors that + -- reflect traffic state + procedure Set_Local_Overload(Sensor_Level : Load_Factor) is + begin + if Local_State = Clear_Level then + -- Notify "previous" ramp to check this one for current state. + -- Subsequent changes in state will not send an alert + -- When the situation clears another routine performs the + -- all_clear notification. (not shown) + -- EXTERNAL CALL OF PROCEDURE FROM PROCEDURE + Ramp_Array(This_Ramp - 1).Notify; -- index to previous ramp + end if; + Local_State := Sensor_Level; + null; --::::: Start local meter if not already started + end Set_Local_Overload; + + function Local_Overload return Load_Factor is + begin + return Local_State; + end Local_Overload; + + -- This is notification from the next ramp that it is in + -- overload. With this provision we only need to sample the next + -- ramp during adverse conditions. + procedure Notify is + begin + Next_Ramp_Alert := true; + end Notify; + + function Next_Ramp_Overload return Load_Factor is + begin + if Next_Ramp_Alert then + -- EXTERNAL FUNCTION CALL FROM FUNCTION + -- Get next ramp's current state + return Ramp_Array(This_Ramp + 1).Local_Overload; + else + return Clear_Level; + end if; + end Next_Ramp_Overload; + end Ramp; + + --================================================================ + + +begin + + + Report.Test ("C940011", "Protected Objects created by allocators: " & + "external calls via access types"); + + -- Initialize each Ramp + for i in Ramp_Index loop + Ramp_Array(i).Set_Index (i); + end loop; + + -- Test driver. This is ALL test control code + + -- Simulate calls to the protected functions and procedures + -- external calls. (do not call the "dummy" end ramps) + + -- Simple Call + if Ramp_Array(2).Next_Ramp_Overload /= Clear_level then + Report.Failed ("Primary call incorrect"); + end if; + + -- Call which results in an external procedure call via the array + -- index from within the protected object + Ramp_Array(3).Set_Local_Overload (Moderate_Level); + + -- Call which results in an external function call via the array + -- index from within the protected object + if Ramp_Array(2).Next_Ramp_Overload /= Moderate_level then + Report.Failed ("Secondary call incorrect"); + end if; + + Report.Result; + +end C940011; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940012.a b/gcc/testsuite/ada/acats/tests/c9/c940012.a new file mode 100644 index 000000000..d4bd2079c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940012.a @@ -0,0 +1,174 @@ +-- C940012.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a protected object can have discriminants +-- +-- TEST DESCRIPTION: +-- Use a subset of the simulation of the freeway on-ramp described in +-- c940005. In this case an array of access types is built with pointers +-- to successive ramps. Each ramp has its Ramp_Number specified by +-- discriminant and this corresponds to the index in the array. The test +-- checks that the ramp numbers are assigned as expected then uses calls +-- to procedures within the objects (ramps) to verify external calls to +-- ensure the structures are valid. The external references within the +-- protected objects are made via the index into the array. Routines +-- which refer to the "previous" ramp and the "next" ramp are exercised. +-- (Note: The first and last ramps are assumed to be dummies and no +-- first/last condition code is included) +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +with Report; + + +procedure C940012 is + + type Ramp_Index is range 1..4; + + type Ramp; + type a_Ramp is access Ramp; + + Ramp_Array : array (Ramp_Index) of a_Ramp; + + -- Weighted load given to each potential problem area and accumulated + type Load_Factor is range 0..8; + Clear_Level : constant Load_Factor := 0; + Moderate_Level : constant Load_Factor := 3; + + --================================================================ + -- Only the Routines that are used in this test are shown + -- + protected type Ramp (Ramp_In : Ramp_Index) is + + function Ramp_Number return Ramp_Index; + function Local_Overload return Load_Factor; + function Next_Ramp_Overload return Load_Factor; + procedure Set_Local_Overload(Sensor_Level : Load_Factor); + procedure Notify; + + private + + Next_Ramp_Alert : Boolean := false; -- Next Ramp is in trouble? + + -- Current state of the various Sample Points + Local_State : Load_Factor := Clear_Level; + + end Ramp; + --================================================================ + protected body Ramp is + + function Ramp_Number return Ramp_Index is + begin + return Ramp_In; + end Ramp_Number; + + -- These Set/Clear routines are triggered by real-time sensors that + -- reflect traffic state + procedure Set_Local_Overload(Sensor_Level : Load_Factor) is + begin + if Local_State = Clear_Level then + -- Notify "previous" ramp to check this one for current state. + -- Subsequent changes in state will not send an alert + -- When the situation clears another routine performs the + -- all_clear notification. (not shown) + Ramp_Array(Ramp_In - 1).Notify; -- index to previous ramp + end if; + Local_State := Sensor_Level; + null; --::::: Start local meter if not already started + end; + + function Local_Overload return Load_Factor is + begin + return Local_State; + end Local_Overload; + + -- This is notification from the next ramp that it is in + -- overload. With this provision we only need to sample the next + -- ramp during adverse conditions. + procedure Notify is + begin + Next_Ramp_Alert := true; + end Notify; + + function Next_Ramp_Overload return Load_Factor is + begin + if Next_Ramp_Alert then + -- Get next ramp's current state + return Ramp_Array(Ramp_In + 1).Local_Overload; + else + return Clear_Level; + end if; + end Next_Ramp_Overload; + end Ramp; + --================================================================ + +begin + + + Report.Test ("C940012", "Check that a protected object " & + "can have discriminants"); + + -- Build the ramps and populate the ramp array + for i in Ramp_Index loop + Ramp_Array(i) := new Ramp (i); + end loop; + + -- Test driver. This is ALL test control code + + -- Check the assignment of the index + for i in Ramp_Index loop + if Ramp_Array(i).Ramp_Number /= i then + Report.Failed ("Ramp_Number assignment incorrect"); + end if; + end loop; + + -- Simulate calls to the protected functions and procedures + -- external calls. (do not call the "dummy" end ramps) + + -- Simple Call + if Ramp_Array(2).Next_Ramp_Overload /= Clear_level then + Report.Failed ("Primary call incorrect"); + end if; + + -- Call which results in an external procedure call via the array + -- index from within the protected object + Ramp_Array(3).Set_Local_Overload (Moderate_Level); + + -- Call which results in an external function call via the array + -- index from within the protected object + if Ramp_Array(2).Next_Ramp_Overload /= Moderate_level then + Report.Failed ("Secondary call incorrect"); + end if; + + + Report.Result; + +end C940012; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940013.a b/gcc/testsuite/ada/acats/tests/c9/c940013.a new file mode 100644 index 000000000..58d34bc96 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940013.a @@ -0,0 +1,379 @@ +-- C940013.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that items queued on a protected entry are handled FIFO and that +-- the 'count attribute of that entry reflects the length of the queue. +-- +-- TEST DESCRIPTION: +-- Use a small subset of the freeway ramp simulation shown in other +-- tests. With the timing pulse off (which prevents items from being +-- removed from the queue) queue up a small number of calls. Start the +-- timing pulse and, at the first execution of the entry code, check the +-- 'count attribute. Empty the queue. Pass the items being removed from +-- the queue to the Ramp_Sensor_01 task; there check that the items are +-- arriving in FIFO order. Check the final 'count value +-- +-- Send another batch of items at a rate which will, if the delay timing +-- of the implementation is reasonable, cause the queue length to +-- fluctuate in both directions. Again check that all items arrive +-- FIFO. At the end check that the 'count returned to zero reflecting +-- the empty queue. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; +with ImpDef; +with Ada.Calendar; + +procedure C940013 is + + TC_Failed_1 : Boolean := false; + +begin + + Report.Test ("C940013", "Check that queues on protected entries are " & + "handled FIFO and that 'count is correct"); + + declare -- encapsulate the test + + function "+" (Left : Ada.Calendar.Time; Right: Duration) + return Ada.Calendar.Time renames Ada.Calendar."+"; + + -- Weighted load given to each potential problem area and accumulated + type Load_Factor is range 0..8; + Clear_Level : constant Load_Factor := 0; + Minimum_Level : constant Load_Factor := 1; + Moderate_Level : constant Load_Factor := 2; + Serious_Level : constant Load_Factor := 4; + Critical_Level : constant Load_Factor := 6; + + TC_Expected_Passage_Total : constant integer := 624; + + -- For this test give each vehicle an integer ID incremented + -- by one for each successive vehicle. In reality this would be + -- a more complex alpha-numeric ID assigned at pickup time. + type Vehicle_ID is range 1..5000; + Next_ID : Vehicle_ID := Vehicle_ID'first; + + -- In reality this would be about 5 seconds. The default value of + -- this constant in the implementation defined package is similar + -- but could, of course be considerably different - it would not + -- affect the test + -- + Pulse_Time_Delta : duration := ImpDef.Clear_Ready_Queue; + + + task Pulse_Task; -- task to generate a pulse for each ramp + + -- Carrier task. One is created for each vehicle arriving at the ramp + task type Vehicle is + entry Get_ID (Input_ID : in Vehicle_ID); + end Vehicle; + type acc_Vehicle is access Vehicle; + + task Ramp_Sensor_01 is + entry Accept_Vehicle (Input_ID : in Vehicle_ID); + entry TC_First_Three_Handled; + entry TC_All_Done; + end Ramp_Sensor_01; + + protected Pulse_State is + procedure Start_Pulse; + procedure Stop_Pulse; + function Pulsing return Boolean; + private + State : Boolean := false; -- start test will pulse off + end Pulse_State; + + protected body Pulse_State is + + procedure Start_Pulse is + begin + State := true; + end Start_Pulse; + + procedure Stop_Pulse is + begin + State := false; + end Stop_Pulse; + + function Pulsing return Boolean is + begin + return State; + end Pulsing; + + end Pulse_State; + + --================================================================ + protected Test_Ramp is + + function Meter_in_use_State return Boolean; + procedure Time_Pulse_Received; + entry Wait_at_Meter; + procedure TC_Passage (Pass_Point : Integer); + function TC_Get_Passage_Total return integer; + function TC_Get_Count return integer; + + private + + Release_One_Vehicle : Boolean := false; + -- For this test have Meter_in_Use already set + Meter_in_Use : Boolean := true; + + TC_Wait_at_Meter_First : Boolean := true; + TC_Entry_Queue_Count : integer := 0; -- 'count of Wait_at_Meter + TC_Passage_Total : integer := 0; + TC_Pass_Point_WAM : integer := 23; + + end Test_Ramp; + --================================================================ + protected body Test_Ramp is + + -- External call for Meter_in_Use + function Meter_in_Use_State return Boolean is + begin + return Meter_in_Use; + end Meter_in_Use_State; + + -- Trace the paths through the various routines by totalling the + -- weighted call parameters + procedure TC_Passage (Pass_Point : Integer) is + begin + TC_Passage_Total := TC_Passage_Total + Pass_Point; + end TC_Passage; + + -- For the final check of the whole test + function TC_Get_Passage_Total return integer is + begin + return TC_Passage_Total; + end TC_Get_Passage_Total; + + function TC_Get_Count return integer is + begin + return TC_Entry_Queue_Count; + end TC_Get_Count; + + + -- Here each Vehicle task queues itself awaiting release + -- + entry Wait_at_Meter when Release_One_Vehicle is + -- EXAMPLE OF ENTRY WITH BARRIERS AND PERSISTENT SIGNAL + begin + -- + TC_Passage ( TC_Pass_Point_WAM ); -- note passage + -- For this test three vehicles are queued before the first + -- is released. If the queueing mechanism is working correctly + -- the first time we pass through here the entry'count should + -- reflect this + if TC_Wait_at_Meter_First then + if Wait_at_Meter'count /= 2 then + TC_Failed_1 := true; + end if; + TC_Wait_at_Meter_First := false; + end if; + TC_Entry_Queue_Count := Wait_at_Meter'count; -- note for later + + Release_One_Vehicle := false; -- Consume the signal + null; -- stub ::: Decrement count of number of vehicles on ramp + end Wait_at_Meter; + + + procedure Time_Pulse_Received is + Load : Load_factor := Minimum_Level; -- for this version of the + Freeway_Breakdown : Boolean := false; -- test, freeway is Minimum + begin + -- if broken down, no vehicles are released + if not Freeway_Breakdown then + if Load < Moderate_Level then + Release_One_Vehicle := true; + end if; + null; -- stub ::: If other levels, release every other + -- pulse, every third pulse etc. + end if; + end Time_Pulse_Received; + + end Test_Ramp; + --================================================================ + + -- Simulate the arrival of a vehicle at the Ramp_Receiver and the + -- generation of an accompanying carrier task + procedure New_Arrival is + Next_Vehicle_Task: acc_Vehicle := new Vehicle; + TC_Pass_Point : constant integer := 3; + begin + Next_ID := Next_ID + 1; + Next_Vehicle_Task.Get_ID(Next_ID); + Test_Ramp.TC_Passage ( TC_Pass_Point ); -- Note passage through here + null; + end New_arrival; + + + -- Carrier task. One is created for each vehicle arriving at the ramp + task body Vehicle is + This_ID : Vehicle_ID; + TC_Pass_Point_2 : constant integer := 21; + begin + accept Get_ID (Input_ID : in Vehicle_ID) do + This_ID := Input_ID; + end Get_ID; + + if Test_Ramp.Meter_in_Use_State then + Test_Ramp.TC_Passage ( TC_Pass_Point_2 ); -- note passage + null; -- stub::: Increment count of number of vehicles on ramp + Test_Ramp.Wait_at_Meter; -- Queue on the meter entry + end if; + + -- Call to the first in the series of the Ramp_Sensors + -- this "passes" the vehicle from one sensor to the next + -- Each sensor will requeue the call to the next thus this + -- rendezvous will only be completed as the vehicle is released + -- by the last sensor on the ramp. + Ramp_Sensor_01.Accept_Vehicle (This_ID); + exception + when others => + Report.Failed ("Unexpected exception in Vehicle Task"); + end Vehicle; + + task body Ramp_Sensor_01 is + TC_Pass_Point : constant integer := 31; + This_ID : Vehicle_ID; + TC_Last_ID : Vehicle_ID := Vehicle_ID'first; + begin + loop + select + accept Accept_Vehicle (Input_ID : in Vehicle_ID) do + null; -- stub:::: match up with next Real-Time notification + -- from the sensor. Requeue to next ramp sensor + This_ID := Input_ID; + + -- The following is all Test_Control code + Test_Ramp.TC_Passage ( TC_Pass_Point ); -- note passage + -- The items arrive in the order they are taken from + -- the Wait_at_Meter entry queue + if ( This_ID - TC_Last_ID ) /= 1 then + -- The tasks are being queued (or unqueued) in the + -- wrong order + Report.Failed + ("Queueing on the Wait_at_Meter queue failed"); + end if; + TC_Last_ID := This_ID; -- for the next check + if TC_Last_ID = 4 then + -- rendezvous with the test driver + accept TC_First_Three_Handled; + elsif TC_Last_ID = 9 then + -- rendezvous with the test driver + accept TC_All_Done; + end if; + end Accept_Vehicle; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Ramp_Sensor_01"); + end Ramp_Sensor_01; + + + -- Task transmits a synchronizing "pulse" to all ramps + -- + task body Pulse_Task is + Pulse_Time : Ada.Calendar.Time; + begin + While not Pulse_State.Pulsing loop + -- Starts up in the quiescent state + delay ImpDef.Minimum_Task_Switch; + end loop; + Pulse_Time := Ada.Calendar.Clock; + While Pulse_State.Pulsing loop + delay until Pulse_Time; + Test_Ramp. Time_Pulse_Received; -- Transmit pulse to test_ramp + -- :::::::::: and to all the other ramps + Pulse_Time := Pulse_Time + Pulse_Time_Delta; -- calculate next + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Pulse_Task"); + end Pulse_Task; + + + begin -- declare + + -- Test driver. This is ALL test control code + + -- Arrange to queue three vehicles on the Wait_at_Meter queue. The + -- timing pulse is quiescent so the queue will build + for i in 1..3 loop + New_Arrival; + end loop; + + delay Pulse_Time_Delta; -- ensure all is settled + + Pulse_State.Start_Pulse; -- Start the timing pulse, the queue will + -- be serviced + + -- wait here until the first three are complete + Ramp_Sensor_01.TC_First_Three_Handled; + + if Test_Ramp.TC_Get_Count /= 0 then + Report.Failed ("Intermediate Wait_at_Entry'count is incorrect"); + end if; + + -- generate new arrivals at a rate that will make the queue increase + -- and decrease "randomly" + for i in 1..5 loop + New_Arrival; + delay Pulse_Time_Delta/2; + end loop; + + -- wait here till all have been handled + Ramp_Sensor_01.TC_All_Done; + + if Test_Ramp.TC_Get_Count /= 0 then + Report.Failed ("Final Wait_at_Entry'count is incorrect"); + end if; + + Pulse_State.Stop_Pulse; -- finish test + + + if TC_Expected_Passage_Total /= Test_Ramp.TC_Get_Passage_Total then + Report.Failed ("Unexpected paths taken"); + end if; + + + end; -- declare + + if TC_Failed_1 then + Report.Failed ("Wait_at_Meter'count incorrect"); + end if; + + Report.Result; + +end C940013; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940014.a b/gcc/testsuite/ada/acats/tests/c9/c940014.a new file mode 100644 index 000000000..0eb53ea51 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940014.a @@ -0,0 +1,177 @@ +-- C940014.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- TEST OBJECTIVE: +-- Check that as part of the finalization of a protected object +-- each call remaining on an entry queue of the objet is removed +-- from its queue and Program_Error is raised at the place of +-- the corresponding entry_call_statement. +-- +-- TEST DESCRIPTION: +-- The example in 9.4(20a-20f);6.0 demonstrates how to cause a +-- protected object to finalize while tasks are still waiting +-- on its entry queues. The first part of this test mirrors +-- that example. The second part of the test expands upon +-- the example code to add an object with finalization code +-- to the protected object. The finalization code should be +-- executed after Program_Error is raised in the callers left +-- on the entry queues. +-- +-- +-- CHANGE HISTORY: +-- 08 Jan 96 SAIC Initial Release for 2.1 +-- 10 Jul 96 SAIC Incorporated Reviewer comments to fix race +-- condition. +-- +--! + + +with Ada.Finalization; +package C940014_0 is + Verbose : constant Boolean := False; + Finalization_Occurred : Boolean := False; + + type Has_Finalization is new Ada.Finalization.Limited_Controlled with + record + Placeholder : Integer; + end record; + procedure Finalize (Object : in out Has_Finalization); +end C940014_0; + + +with Report; +with ImpDef; +package body C940014_0 is + procedure Finalize (Object : in out Has_Finalization) is + begin + delay ImpDef.Clear_Ready_Queue; + Finalization_Occurred := True; + if Verbose then + Report.Comment ("in Finalize"); + end if; + end Finalize; +end C940014_0; + + + +with Report; +with ImpDef; +with Ada.Finalization; +with C940014_0; + +procedure C940014 is + Verbose : constant Boolean := C940014_0.Verbose; + +begin + + Report.Test ("C940014", "Check that the finalization of a protected" & + " object results in program_error being raised" & + " at the point of the entry call statement for" & + " any tasks remaining on any entry queue"); + + First_Check: declare + -- example from ARM 9.4(20a-f);6.0 with minor mods + task T is + entry E; + end T; + task body T is + protected PO is + entry Ee; + end PO; + protected body PO is + entry Ee when Report.Ident_Bool (False) is + begin + null; + end Ee; + end PO; + begin + accept E do + requeue PO.Ee; + end E; + if Verbose then + Report.Comment ("task about to terminate"); + end if; + end T; + begin -- First_Check + begin + T.E; + delay ImpDef.Clear_Ready_Queue; + Report.Failed ("exception not raised in First_Check"); + exception + when Program_Error => + if Verbose then + Report.Comment ("ARM Example passed"); + end if; + when others => + Report.Failed ("wrong exception in First_Check"); + end; + end First_Check; + + + Second_Check : declare + -- here we want to check that the raising of Program_Error + -- occurs before the other finalization actions. + task T is + entry E; + end T; + task body T is + protected PO is + entry Ee; + private + Component : C940014_0.Has_Finalization; + end PO; + protected body PO is + entry Ee when Report.Ident_Bool (False) is + begin + null; + end Ee; + end PO; + begin + accept E do + requeue PO.Ee; + end E; + if Verbose then + Report.Comment ("task about to terminate"); + end if; + end T; + begin -- Second_Check + T.E; + delay ImpDef.Clear_Ready_Queue; + Report.Failed ("exception not raised in Second_Check"); + exception + when Program_Error => + if C940014_0.Finalization_Occurred then + Report.Failed ("wrong order for finalization"); + elsif Verbose then + Report.Comment ("Second_Check passed"); + end if; + when others => + Report.Failed ("Wrong exception in Second_Check"); + end Second_Check; + + + Report.Result; + +end C940014; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940015.a b/gcc/testsuite/ada/acats/tests/c9/c940015.a new file mode 100644 index 000000000..92a6699c3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940015.a @@ -0,0 +1,149 @@ +-- C940015.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- TEST OBJECTIVE: +-- Check that the component_declarations of a protected_operation +-- are elaborated in the proper order. +-- +-- TEST DESCRIPTION: +-- A discriminated protected object is declared with some +-- components that depend upon the discriminant and some that +-- do not depend upon the discriminant. All the components +-- are initialized with a function call. As a side-effect of +-- the function call the parameter passed to the function is +-- recorded in an elaboration order array. +-- Two objects of the protected type are declared. The +-- elaboration order is recorded and checked against the +-- expected order. +-- +-- +-- CHANGE HISTORY: +-- 09 Jan 96 SAIC Initial Version for 2.1 +-- 09 Jul 96 SAIC Addressed reviewer comments. +-- 13 Feb 97 PWB.CTA Removed doomed attempt to check per-object +-- constraint elaborations. +--! + + +with Report; + +procedure C940015 is + Verbose : constant Boolean := False; + Do_Display : Boolean := Verbose; + + type Index is range 0..10; + + type List is array (1..10) of Integer; + Last : Natural range 0 .. List'Last := 0; + E_List : List := (others => 0); + + function Elaborate (Id : Integer) return Index is + begin + Last := Last + 1; + E_List (Last) := Id; + if Verbose then + Report.Comment ("Elaborating" & Integer'Image (Id)); + end if; + return Index(Id mod 10); + end Elaborate; + + function Elaborate (Id, Per_Obj_Expr : Integer) return Index is + begin + return Elaborate (Id); + end Elaborate; + +begin + + Report.Test ("C940015", "Check that the component_declarations of a" & + " protected object are elaborated in the" & + " proper order"); + declare + -- an unprotected queue type + type Storage is array (Index range <>) of Integer; + type Queue (Size, Flag : Index := 1) is + record + Head : Index := 1; + Tail : Index := 1; + Count : Index := 0; + Buffer : Storage (1..Size); + end record; + + -- protected group of queues type + protected type Prot_Queues (Size : Index := Elaborate (104)) is + procedure Clear; + -- other needed procedures not provided at this time + private + -- elaborate at type elaboration + Fixed_Queue_1 : Queue (3, + Elaborate (105)); + -- elaborate at type elaboration + Fixed_Queue_2 : Queue (6, + Elaborate (107)); + end Prot_Queues; + protected body Prot_Queues is + procedure Clear is + begin + Fixed_Queue_1.Count := 0; + Fixed_Queue_1.Head := 1; + Fixed_Queue_1.Tail := 1; + Fixed_Queue_2.Count := 0; + Fixed_Queue_2.Head := 1; + Fixed_Queue_2.Tail := 1; + end Clear; + end Prot_Queues; + + PO1 : Prot_Queues(9); + PO2 : Prot_Queues; + + Expected_Elab_Order : List := ( + -- from the elaboration of the protected type Prot_Queues + 105, 107, + -- from the unconstrained object PO2 + 104, + others => 0); + begin + for I in List'Range loop + if E_List (I) /= Expected_Elab_Order (I) then + Report.Failed ("wrong elaboration order"); + Do_Display := True; + end if; + end loop; + if Do_Display then + Report.Comment ("Expected Actual"); + for I in List'Range loop + Report.Comment ( + Integer'Image (Expected_Elab_Order(I)) & + Integer'Image (E_List(I))); + end loop; + end if; + + -- make use of the protected objects + PO1.Clear; + PO2.Clear; + end; + + Report.Result; + +end C940015; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940016.a b/gcc/testsuite/ada/acats/tests/c9/c940016.a new file mode 100644 index 000000000..2226eefb4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940016.a @@ -0,0 +1,211 @@ +-- C940016.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- TEST OBJECTIVE: +-- Check that an Unchecked_Deallocation of a protected object +-- performs the required finalization on the protected object. +-- +-- TEST DESCRIPTION: +-- Test that finalization takes place when an Unchecked_Deallocation +-- deallocates a protected object with queued callers. +-- Try protected objects that have no other finalization code and +-- protected objects with user defined finalization. +-- +-- +-- CHANGE HISTORY: +-- 16 Jan 96 SAIC ACVC 2.1 +-- 10 Jul 96 SAIC Fixed race condition noted by reviewers. +-- +--! + + +with Ada.Finalization; +package C940016_0 is + Verbose : constant Boolean := False; + Finalization_Occurred : Boolean := False; + + type Has_Finalization is new Ada.Finalization.Limited_Controlled with + record + Placeholder : Integer; + end record; + procedure Finalize (Object : in out Has_Finalization); +end C940016_0; + + +with Report; +with ImpDef; +package body C940016_0 is + procedure Finalize (Object : in out Has_Finalization) is + begin + delay ImpDef.Clear_Ready_Queue; + Finalization_Occurred := True; + if Verbose then + Report.Comment ("in Finalize"); + end if; + end Finalize; +end C940016_0; + + + +with Report; +with Ada.Finalization; +with C940016_0; +with Ada.Unchecked_Deallocation; +with ImpDef; + +procedure C940016 is + Verbose : constant Boolean := C940016_0.Verbose; + +begin + + Report.Test ("C940016", "Check that Unchecked_Deallocation of a" & + " protected object finalizes the" & + " protected object"); + + First_Check: declare + protected type Semaphore is + entry Wait; + procedure Signal; + private + Count : Integer := 0; + end Semaphore; + protected body Semaphore is + entry Wait when Count > 0 is + begin + Count := Count - 1; + end Wait; + + procedure Signal is + begin + Count := Count + 1; + end Signal; + end Semaphore; + + type pSem is access Semaphore; + procedure Zap_Semaphore is new + Ada.Unchecked_Deallocation (Semaphore, pSem); + Sem_Ptr : pSem := new Semaphore; + + -- positive confirmation that Blocker got the exception + Ok : Boolean := False; + + task Blocker; + + task body Blocker is + begin + Sem_Ptr.Wait; + Report.Failed ("Program_Error not raised in waiting task"); + exception + when Program_Error => + Ok := True; + if Verbose then + Report.Comment ("Blocker received Program_Error"); + end if; + when others => + Report.Failed ("Wrong exception in Blocker"); + end Blocker; + + begin -- First_Check + -- wait for Blocker to get blocked on the semaphore + delay ImpDef.Clear_Ready_Queue; + Zap_Semaphore (Sem_Ptr); + -- make sure Blocker has time to complete + delay ImpDef.Clear_Ready_Queue * 2; + if not Ok then + Report.Failed ("finalization not properly performed"); + -- Blocker is probably hung so kill it + abort Blocker; + end if; + end First_Check; + + + Second_Check : declare + -- here we want to check that the raising of Program_Error + -- occurs before the other finalization actions. + protected type Semaphore is + entry Wait; + procedure Signal; + private + Count : Integer := 0; + Component : C940016_0.Has_Finalization; + end Semaphore; + protected body Semaphore is + entry Wait when Count > 0 is + begin + Count := Count - 1; + end Wait; + + procedure Signal is + begin + Count := Count + 1; + end Signal; + end Semaphore; + + type pSem is access Semaphore; + procedure Zap_Semaphore is new + Ada.Unchecked_Deallocation (Semaphore, pSem); + Sem_Ptr : pSem := new Semaphore; + + -- positive confirmation that Blocker got the exception + Ok : Boolean := False; + + task Blocker; + + task body Blocker is + begin + Sem_Ptr.Wait; + Report.Failed ("Program_Error not raised in waiting task 2"); + exception + when Program_Error => + Ok := True; + if C940016_0.Finalization_Occurred then + Report.Failed ("wrong order for finalization 2"); + elsif Verbose then + Report.Comment ("Blocker received Program_Error 2"); + end if; + when others => + Report.Failed ("Wrong exception in Blocker 2"); + end Blocker; + + begin -- Second_Check + -- wait for Blocker to get blocked on the semaphore + delay ImpDef.Clear_Ready_Queue; + Zap_Semaphore (Sem_Ptr); + -- make sure Blocker has time to complete + delay ImpDef.Clear_Ready_Queue * 2; + if not Ok then + Report.Failed ("finalization not properly performed 2"); + -- Blocker is probably hung so kill it + abort Blocker; + end if; + if not C940016_0.Finalization_Occurred then + Report.Failed ("user defined finalization didn't happen"); + end if; + end Second_Check; + + + Report.Result; + +end C940016; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94001a.ada b/gcc/testsuite/ada/acats/tests/c9/c94001a.ada new file mode 100644 index 000000000..e23a3b86d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94001a.ada @@ -0,0 +1,259 @@ +-- C94001A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A UNIT WITH DEPENDENT TASKS CREATED BY OBJECT +-- DECLARATIONS IS NOT TERMINATED UNTIL ALL DEPENDENT TASKS BECOME +-- TERMINATED. +-- SUBTESTS ARE: +-- (A, B) A SIMPLE TASK OBJECT, IN A BLOCK. +-- (C, D) AN ARRAY OF TASK OBJECT, IN A FUNCTION. +-- (E, F) AN ARRAY OF RECORD OF TASK OBJECT, IN A TASK BODY. + +-- THIS TEST CONTAINS SHARED VARIABLES AND RACE CONDITIONS. + +-- JRK 10/2/81 +-- SPS 11/21/82 +-- JRK 11/29/82 +-- TBN 8/22/86 REVISED; ADDED CASES THAT EXIT BY RAISING AN +-- EXCEPTION. +-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94001A IS + + MY_EXCEPTION : EXCEPTION; + GLOBAL : INTEGER; + + TASK TYPE TT IS + ENTRY E (I : INTEGER); + END TT; + + TASK BODY TT IS + LOCAL : INTEGER; + BEGIN + ACCEPT E (I : INTEGER) DO + LOCAL := I; + END E; + DELAY 30.0 * Impdef.One_Second; -- SINCE THE PARENT UNIT HAS HIGHER PRIORITY + -- AT THIS POINT, IT WILL RECEIVE CONTROL AND + -- TERMINATE IF THE ERROR IS PRESENT. + GLOBAL := LOCAL; + END TT; + + +BEGIN + TEST ("C94001A", "CHECK THAT A UNIT WITH DEPENDENT TASKS " & + "CREATED BY OBJECT DECLARATIONS IS NOT " & + "TERMINATED UNTIL ALL DEPENDENT TASKS " & + "BECOME TERMINATED"); + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (A) + + T : TT; + + BEGIN -- (A) + + T.E (IDENT_INT(1)); + + END; -- (A) + + IF GLOBAL /= 1 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 1"); + END IF; + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + BEGIN -- (B) + DECLARE + T : TT; + BEGIN + T.E (IDENT_INT(1)); + RAISE MY_EXCEPTION; + END; + + FAILED ("MY_EXCEPTION WAS NOT RAISED - 2"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 1 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 2"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 2"); + END; -- (B) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + BEGIN + A(1).E (IDENT_INT(2)); + RETURN 0; + END F; + + BEGIN -- (C) + + I := F; + + IF GLOBAL /= 2 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 3"); + END IF; + + END; -- (C) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (D) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + BEGIN + A(1).E (IDENT_INT(2)); + IF EQUAL (3, 3) THEN + RAISE MY_EXCEPTION; + END IF; + RETURN 0; + END F; + + BEGIN -- (D) + I := F; + FAILED ("MY_EXCEPTION WAS NOT RAISED - 4"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 2 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 4"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 4"); + END; -- (D) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (E) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60 * 60; -- ONE HOUR DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE RT IS + RECORD + T : TT; + END RECORD; + AR : ARRAY (1..1) OF RT; + BEGIN + AR(1).T.E (IDENT_INT(3)); + END TSK; + + BEGIN -- (E) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN ONE " & + "HOUR - 5"); + ELSIF GLOBAL /= 3 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "TASK EXIT - 5"); + END IF; + + END; -- (E) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (F) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60 * 60; -- ONE HOUR DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE RT IS + RECORD + T : TT; + END RECORD; + AR : ARRAY (1..1) OF RT; + BEGIN + AR(1).T.E (IDENT_INT(3)); + IF EQUAL (3, 3) THEN + RAISE MY_EXCEPTION; + END IF; + FAILED ("EXCEPTION WAS NOT RAISED - 6"); + END TSK; + + BEGIN -- (F) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN ONE " & + "HOUR - 6"); + ELSIF GLOBAL /= 3 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "TASK EXIT - 6"); + END IF; + + END; -- (F) + + -------------------------------------------------- + + RESULT; +END C94001A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94001b.ada b/gcc/testsuite/ada/acats/tests/c9/c94001b.ada new file mode 100644 index 000000000..e3e2edaa3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94001b.ada @@ -0,0 +1,268 @@ +-- C94001B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A UNIT WITH DEPENDENT TASKS CREATED BY AN OBJECT +-- DECLARATION OF LIMITED PRIVATE TYPE IS NOT TERMINATED UNTIL ALL +-- DEPENDENT TASKS BECOME TERMINATED. +-- SUBTESTS ARE: +-- (A, B) A SIMPLE TASK OBJECT, IN A BLOCK. +-- (C, D) AN ARRAY OF TASK OBJECT, IN A FUNCTION. +-- (E, F) AN ARRAY OF RECORD OF TASK OBJECT, IN A TASK BODY. + +-- THIS TEST CONTAINS SHARED VARIABLES AND RACE CONDITIONS. + +-- TBN 8/22/86 +-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94001B IS + + PACKAGE P IS + MY_EXCEPTION : EXCEPTION; + GLOBAL : INTEGER; + TYPE TT IS LIMITED PRIVATE; + PROCEDURE CALL_ENTRY (A : TT; B : INTEGER); + PRIVATE + TASK TYPE TT IS + ENTRY E (I : INTEGER); + END TT; + END P; + + PACKAGE BODY P IS + + PROCEDURE CALL_ENTRY (A : TT; B : INTEGER) IS + BEGIN + A.E (B); + END CALL_ENTRY; + + TASK BODY TT IS + LOCAL : INTEGER; + BEGIN + ACCEPT E (I : INTEGER) DO + LOCAL := I; + END E; + DELAY 30.0 * Impdef.One_Second; -- SINCE THE PARENT UNIT HAS HIGHER + -- PRIORITY AT THIS POINT, IT WILL + -- RECEIVE CONTROL AND TERMINATE IF + -- THE ERROR IS PRESENT. + GLOBAL := LOCAL; + END TT; + END P; + + USE P; + + +BEGIN + TEST ("C94001B", "CHECK THAT A UNIT WITH DEPENDENT TASKS " & + "CREATED BY AN OBJECT DECLARATION OF LIMITED " & + "PRIVATE TYPE IS NOT TERMINATED UNTIL ALL " & + "DEPENDENT TASKS BECOME TERMINATED"); + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (A) + + T : TT; + + BEGIN -- (A) + + CALL_ENTRY (T, IDENT_INT(1)); + + END; -- (A) + + IF GLOBAL /= 1 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 1"); + END IF; + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + BEGIN -- (B) + DECLARE + T : TT; + BEGIN + CALL_ENTRY (T, IDENT_INT(2)); + RAISE MY_EXCEPTION; + END; + + FAILED ("MY_EXCEPTION WAS NOT RAISED - 2"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 2 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 2"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 2"); + END; -- (B) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + BEGIN + CALL_ENTRY (A(1), IDENT_INT(3)); + RETURN 0; + END F; + + BEGIN -- (C) + + I := F; + + IF GLOBAL /= 3 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 3"); + END IF; + + END; -- (C) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (D) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + BEGIN + CALL_ENTRY (A(1), IDENT_INT(4)); + IF EQUAL (3, 3) THEN + RAISE MY_EXCEPTION; + END IF; + RETURN 0; + END F; + + BEGIN -- (D) + I := F; + FAILED ("MY_EXCEPTION WAS NOT RAISED - 4"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 4 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 4"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 4"); + END; -- (D) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (E) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60 * 60; -- ONE HOUR DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE RT IS + RECORD + T : TT; + END RECORD; + AR : ARRAY (1..1) OF RT; + BEGIN + CALL_ENTRY (AR(1).T, IDENT_INT(5)); + END TSK; + + BEGIN -- (E) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN ONE " & + "HOUR - 5"); + ELSIF GLOBAL /= 5 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "TASK EXIT - 5"); + END IF; + + END; -- (E) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (F) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60 * 60; -- ONE HOUR DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE RT IS + RECORD + T : TT; + END RECORD; + AR : ARRAY (1..1) OF RT; + BEGIN + CALL_ENTRY (AR(1).T, IDENT_INT(6)); + IF EQUAL (3, 3) THEN + RAISE MY_EXCEPTION; + END IF; + FAILED ("EXCEPTION WAS NOT RAISED - 6"); + END TSK; + + BEGIN -- (F) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN ONE " & + "HOUR - 6"); + ELSIF GLOBAL /= 6 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "TASK EXIT - 6"); + END IF; + + END; -- (F) + + RESULT; +END C94001B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94001c.ada b/gcc/testsuite/ada/acats/tests/c9/c94001c.ada new file mode 100644 index 000000000..1d0625559 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94001c.ada @@ -0,0 +1,267 @@ +-- C94001C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A UNIT WITH INDIRECT DEPENDENT TASKS CREATED BY OBJECT +-- DECLARATIONS IS NOT TERMINATED UNTIL ALL INDIRECT DEPENDENT TASKS +-- BECOME TERMINATED. +-- SUBTESTS ARE: +-- (A, B) A BLOCK CONTAINING A SIMPLE TASK OBJECT, IN A BLOCK. +-- (C, D) A FUNCTION CONTAINING AN ARRAY OF TASK OBJECT, IN A +-- FUNCTION. +-- (E, F) A TASK CONTAINING AN ARRAY OF RECORD OF TASK OBJECT, +-- IN A TASK BODY. +-- CASES (B, D, F) EXIT BY RAISING AN EXCEPTION. + +-- THIS TEST CONTAINS SHARED VARIABLES AND RACE CONDITIONS. + +-- TBN 8/25/86 +-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94001C IS + + MY_EXCEPTION : EXCEPTION; + GLOBAL : INTEGER; + + TASK TYPE TT IS + ENTRY E (I : INTEGER); + END TT; + + TASK BODY TT IS + LOCAL : INTEGER; + BEGIN + ACCEPT E (I : INTEGER) DO + LOCAL := I; + END E; + DELAY 30.0 * Impdef.One_Second; -- SINCE THE PARENT UNIT HAS HIGHER PRIORITY + -- AT THIS POINT, IT WILL RECEIVE CONTROL AND + -- TERMINATE IF THE ERROR IS PRESENT. + GLOBAL := LOCAL; + END TT; + + +BEGIN + TEST ("C94001C", "CHECK THAT A UNIT WITH INDIRECT DEPENDENT " & + "TASKS CREATED BY OBJECT DECLARATIONS IS NOT " & + "TERMINATED UNTIL ALL INDIRECT DEPENDENT TASKS " & + "BECOME TERMINATED"); + + -------------------------------------------------- + GLOBAL := IDENT_INT (0); + + BEGIN -- (A) + + DECLARE + T : TT; + BEGIN + T.E (IDENT_INT(1)); + END; + + END; -- (A) + + IF GLOBAL /= 1 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 1"); + END IF; + + -------------------------------------------------- + + BEGIN -- (B) + GLOBAL := IDENT_INT (0); + + BEGIN + DECLARE + T : TT; + BEGIN + T.E (IDENT_INT(2)); + RAISE MY_EXCEPTION; + END; + END; + + FAILED ("MY_EXCEPTION WAS NOT RAISED - 2"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 2 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 2"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 2"); + END; -- (B) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C) + + OBJ_INT : INTEGER; + + FUNCTION F1 RETURN INTEGER IS + I : INTEGER; + + FUNCTION F2 RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + BEGIN + A(1).E (IDENT_INT(3)); + RETURN 0; + END F2; + BEGIN + I := F2; + RETURN (0); + END F1; + + BEGIN -- (C) + OBJ_INT := F1; + IF GLOBAL /= 3 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 3"); + END IF; + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D) + + OBJ_INT : INTEGER; + + FUNCTION F1 RETURN INTEGER IS + I : INTEGER; + + FUNCTION F2 RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + BEGIN + A(1).E (IDENT_INT(4)); + IF EQUAL (3, 3) THEN + RAISE MY_EXCEPTION; + END IF; + RETURN 0; + END F2; + BEGIN + I := F2; + RETURN (0); + END F1; + + BEGIN -- (D) + GLOBAL := IDENT_INT (0); + OBJ_INT := F1; + FAILED ("MY_EXCEPTION WAS NOT RAISED - 4"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 4 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 4"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 4"); + END; -- (D) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (E) + DELAY_COUNT : INTEGER := 0; + TASK OUT_TSK; + + TASK BODY OUT_TSK IS + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE RT IS + RECORD + T : TT; + END RECORD; + AR : ARRAY (1..1) OF RT; + BEGIN + AR(1).T.E (IDENT_INT(5)); + END TSK; + + BEGIN + NULL; + END OUT_TSK; + + BEGIN -- (E) + WHILE NOT(OUT_TSK'TERMINATED) AND DELAY_COUNT < 60 LOOP + DELAY 1.0 * Impdef.One_Long_Second; + DELAY_COUNT := DELAY_COUNT + 1; + END LOOP; + IF DELAY_COUNT = 60 THEN + FAILED ("OUT_TSK HAS NOT TERMINATED - 5"); + ELSIF GLOBAL /= 5 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 5"); + END IF; + END; -- (E) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE + DELAY_COUNT : INTEGER := 0; + + TASK OUT_TSK; + + TASK BODY OUT_TSK IS + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE RT IS + RECORD + T : TT; + END RECORD; + AR : ARRAY (1..1) OF RT; + BEGIN + AR(1).T.E (IDENT_INT(6)); + RAISE MY_EXCEPTION; + END TSK; + + BEGIN + RAISE MY_EXCEPTION; + END OUT_TSK; + + BEGIN + WHILE NOT(OUT_TSK'TERMINATED) AND DELAY_COUNT < 60 LOOP + DELAY 1.0 * Impdef.One_Long_Second; + DELAY_COUNT := DELAY_COUNT + 1; + END LOOP; + IF DELAY_COUNT = 60 THEN + FAILED ("OUT_TSK HAS NOT TERMINATED - 6"); + ELSIF GLOBAL /= 6 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 6"); + END IF; + END; + + RESULT; +END C94001C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94001e.ada b/gcc/testsuite/ada/acats/tests/c9/c94001e.ada new file mode 100644 index 000000000..4ab502cd5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94001e.ada @@ -0,0 +1,81 @@ +-- C94001E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TASK IS ALSO COMPLETED IF AN EXCEPTION IS RAISED BY +-- THE EXECUTION OF ITS SEQUENCE OF STATEMENTS. +-- THIS MUST HOLD FOR BOTH CASES WHERE A HANDLER IS PRESENT OR NOT. +-- VERSION WITH EXCEPTION HANDLER. + +-- WEI 3/ 4/82 +-- JWC 6/28/85 RENAMED FROM C940AGA-B.ADA +-- RLB 06/29/01 CORRECTED TO ALLOW AGGRESSIVE OPTIMIZATION. + +WITH REPORT; + USE REPORT; +PROCEDURE C94001E IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + +BEGIN + + TEST ("C94001E", "TASK COMPLETION BY EXCEPTION"); + +BLOCK: + DECLARE + + TASK T1; + + TASK BODY T1 IS + TYPE I1 IS RANGE 0 .. 1; + OBJ_I1 : I1; + BEGIN + OBJ_I1 := I1(IDENT_INT(2)); -- CONSTRAINT_ERROR. + IF OBJ_I1 /= I1(IDENT_INT(0)) THEN + PSPY_NUMB (1); + ELSE + PSPY_NUMB (2); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("OTHER EXCEPTION RAISED"); + END T1; + + BEGIN + NULL; + END BLOCK; + + IF SPYNUMB /= 0 THEN + FAILED ("TASK T1 NOT COMPLETED AFTER EXCEPTION"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + +END C94001E; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94001f.ada b/gcc/testsuite/ada/acats/tests/c9/c94001f.ada new file mode 100644 index 000000000..82adc32f6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94001f.ada @@ -0,0 +1,80 @@ +-- C94001F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TASK IS ALSO COMPLETED IF AN EXCEPTION IS RAISED BY +-- THE EXECUTION OF ITS SEQUENCE OF STATEMENTS. +-- THIS MUST HOLD FOR BOTH CASES WHERE A HANDLER IS PRESENT OR NOT. +-- VERSION WITHOUT EXCEPTION HANDLER. + +-- WEI 3/ 4/82 +-- JWC 6/28/85 RENAMED FROM C940AGB-B.ADA + +WITH REPORT; + USE REPORT; +PROCEDURE C94001F IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + +BEGIN + + TEST ("C94001F", "TASK COMPLETION BY EXCEPTION -- NO HANDLER"); + +BLOCK: + DECLARE + + TASK T1; + + TASK BODY T1 IS + TYPE I1 IS RANGE 0 .. 1; + OBJ_I1 : I1; + BEGIN + OBJ_I1 := I1(IDENT_INT(2)); -- CONSTRAINT_ERROR. + PSPY_NUMB (1); + END T1; + + BEGIN + NULL; -- WAIT FOR TERMINATION. + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("PROPAGATED CONSTRAINT_ERROR OUT OF TASK"); + WHEN TASKING_ERROR => + FAILED ("RAISED TASKING_ERROR"); + WHEN OTHERS => + FAILED ("RAISED OTHER EXCEPTION"); + END BLOCK; + + IF SPYNUMB /= 0 THEN + FAILED ("TASK T1 NOT COMPLETED AFTER EXCEPTION IN SEQUENCE " & + "OF STATEMENTS"); + END IF; + + RESULT; + +END C94001F; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94001g.ada b/gcc/testsuite/ada/acats/tests/c9/c94001g.ada new file mode 100644 index 000000000..294bb53a5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94001g.ada @@ -0,0 +1,124 @@ +-- C94001G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A COMPLETED TASK WITH DEPENDENT TASKS TERMINATES WHEN +-- A L L DEPENDENT TASKS HAVE TERMINATED. + +-- WEI 3/ 4/82 +-- JBG 4/2/84 +-- JWC 6/28/85 RENAMED FROM C940AIA-B.ADA + +with Impdef; +WITH REPORT; + USE REPORT; +PROCEDURE C94001G IS + + PACKAGE SPY IS -- PROVIDE PROTECTED ACCESS TO SPYNUMB + SUBTYPE ARG IS NATURAL RANGE 0..9; + FUNCTION SPYNUMB RETURN NATURAL; -- READ + FUNCTION FINIT_POS (DIGT : IN ARG) RETURN NATURAL; -- WRITE + PROCEDURE PSPY_NUMB (DIGT : IN ARG); -- WRITE + END SPY; + + USE SPY; + + PACKAGE BODY SPY IS + + TASK GUARD IS + ENTRY READ (NUMB : OUT NATURAL); + ENTRY WRITE (NUMB : IN NATURAL); + END GUARD; + + TASK BODY GUARD IS + SPYNUMB : NATURAL := 0; + BEGIN + LOOP + SELECT + ACCEPT READ (NUMB : OUT NATURAL) DO + NUMB := SPYNUMB; + END READ; + OR ACCEPT WRITE (NUMB : IN NATURAL) DO + SPYNUMB := 10*SPYNUMB+NUMB; + END WRITE; + OR TERMINATE; + END SELECT; + END LOOP; + END GUARD; + + FUNCTION SPYNUMB RETURN NATURAL IS + TEMP : NATURAL; + BEGIN + GUARD.READ (TEMP); + RETURN TEMP; + END SPYNUMB; + + FUNCTION FINIT_POS (DIGT: IN ARG) RETURN NATURAL IS + BEGIN + GUARD.WRITE (DIGT); + RETURN DIGT; + END FINIT_POS; + + PROCEDURE PSPY_NUMB (DIGT : IN ARG) IS + BEGIN + GUARD.WRITE (DIGT); + END PSPY_NUMB; + END SPY; + +BEGIN + TEST ("C94001G", "TERMINATION WHEN ALL DEPENDENT TASKS " & + "HAVE TERMINATED"); + +BLOCK: + DECLARE + + TASK TYPE TT1; + + TASK BODY TT1 IS + BEGIN + DELAY 1.0 * Impdef.One_Second; + PSPY_NUMB (1); + END TT1; + + TASK T1 IS + END T1; + + TASK BODY T1 IS + OBJ_TT1_1, OBJ_TT1_2, OBJ_TT1_3 : TT1; + BEGIN + NULL; + END T1; + + BEGIN + NULL; + END BLOCK; -- WAIT HERE FOR TERMINATION. + + IF SPYNUMB /= 111 THEN + FAILED ("TASK T1 TERMINATED BEFORE " & + "ALL DEPENDENT TASKS HAVE TERMINATED"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + +END C94001G; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94002a.ada b/gcc/testsuite/ada/acats/tests/c9/c94002a.ada new file mode 100644 index 000000000..6db8f962b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94002a.ada @@ -0,0 +1,331 @@ +-- C94002A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A UNIT WITH DEPENDENT TASKS CREATED BY (LOCAL) +-- ALLOCATORS DOES NOT TERMINATE UNTIL ALL DEPENDENT TASKS ARE +-- TERMINATED. +-- SUBTESTS ARE: +-- (A, B) A SIMPLE TASK ALLOCATOR, IN A BLOCK. +-- (C, D) A RECORD OF TASK ALLOCATOR, IN A FUNCTION. +-- (E, F) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A TASK BODY. + +-- THIS TEST CONTAINS SHARED VARIABLES AND RACE CONDITIONS. + +-- JRK 10/2/81 +-- SPS 11/2/82 +-- SPS 11/21/82 +-- JRK 11/29/82 +-- TBN 8/25/86 REDUCED DELAYS; ADDED LIMITED PRIVATE TYPES; +-- INCLUDED EXITS BY RAISING AN EXCEPTION. +-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94002A IS + + PACKAGE P IS + MY_EXCEPTION : EXCEPTION; + GLOBAL : INTEGER; + TASK TYPE T1 IS + ENTRY E (I : INTEGER); + END T1; + TYPE T2 IS LIMITED PRIVATE; + PROCEDURE CALL_ENTRY (A : T2; B : INTEGER); + PRIVATE + TASK TYPE T2 IS + ENTRY E (I : INTEGER); + END T2; + END P; + + PACKAGE BODY P IS + TASK BODY T1 IS + LOCAL : INTEGER; + BEGIN + ACCEPT E (I : INTEGER) DO + LOCAL := I; + END E; + DELAY 30.0 * Impdef.One_Second; -- SINCE THE PARENT UNIT HAS HIGHER + -- PRIORITY AT THIS POINT, IT WILL + -- RECEIVE CONTROL AND TERMINATE IF + -- THE ERROR IS PRESENT. + GLOBAL := LOCAL; + END T1; + + TASK BODY T2 IS + LOCAL : INTEGER; + BEGIN + ACCEPT E (I : INTEGER) DO + LOCAL := I; + END E; + DELAY 30.0 * Impdef.One_Second; + GLOBAL := LOCAL; + END T2; + + PROCEDURE CALL_ENTRY (A : T2; B : INTEGER) IS + BEGIN + A.E (B); + END CALL_ENTRY; + END P; + + USE P; + + +BEGIN + TEST ("C94002A", "CHECK THAT A UNIT WITH DEPENDENT TASKS " & + "CREATED BY (LOCAL) ALLOCATORS DOES NOT " & + "TERMINATE UNTIL ALL DEPENDENT TASKS " & + "ARE TERMINATED"); + + -------------------------------------------------- + GLOBAL := IDENT_INT (0); + BEGIN -- (A) + DECLARE + TYPE A_T IS ACCESS T1; + A : A_T; + BEGIN + IF EQUAL (3, 3) THEN + A := NEW T1; + A.ALL.E (IDENT_INT(1)); + RAISE MY_EXCEPTION; + END IF; + END; + + FAILED ("MY_EXCEPTION WAS NOT RAISED - 1"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 1 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 1"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + END; -- (A) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (B) + TYPE A_T IS ACCESS T2; + A : A_T; + BEGIN -- (B) + IF EQUAL (3, 3) THEN + A := NEW T2; + CALL_ENTRY (A.ALL, IDENT_INT(2)); + END IF; + END; -- (B) + + IF GLOBAL /= 2 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 2"); + END IF; + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C) + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + TYPE RT; + TYPE ART IS ACCESS RT; + TYPE RT IS + RECORD + A : ART; + T : T1; + END RECORD; + LIST : ART; + TEMP : ART; + BEGIN + FOR I IN 1 .. IDENT_INT (1) LOOP + TEMP := NEW RT; + TEMP.A := LIST; + LIST := TEMP; + LIST.T.E (IDENT_INT(3)); + END LOOP; + RETURN 0; + END F; + BEGIN -- (C) + I := F; + + IF GLOBAL /= 3 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 3"); + END IF; + END; -- (C) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (D) + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + TYPE RT; + TYPE ART IS ACCESS RT; + TYPE RT IS + RECORD + A : ART; + T : T2; + END RECORD; + LIST : ART; + TEMP : ART; + BEGIN + FOR I IN 1 .. IDENT_INT (1) LOOP + TEMP := NEW RT; + TEMP.A := LIST; + LIST := TEMP; + CALL_ENTRY (LIST.T, IDENT_INT(4)); + IF EQUAL (3, 3) THEN + RAISE MY_EXCEPTION; + END IF; + END LOOP; + RETURN 0; + END F; + BEGIN -- (D) + I := F; + + FAILED ("MY_EXCEPTION WAS NOT RAISED - 4"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 4 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 4"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END; -- (D) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (E) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 5 * 60; -- FIVE MINUTE DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE ARR IS ARRAY (1..1) OF T1; + TYPE RAT; + TYPE ARAT IS ACCESS RAT; + TYPE RAT IS + RECORD + A : ARAT; + T : ARR; + END RECORD; + LIST : ARAT; + TEMP : ARAT; + BEGIN + FOR I IN 1 .. IDENT_INT (1) LOOP + TEMP := NEW RAT; + TEMP.A := LIST; + LIST := TEMP; + LIST.T(1).E (IDENT_INT(5)); + IF EQUAL (3, 3) THEN + RAISE MY_EXCEPTION; + END IF; + END LOOP; + END TSK; + + BEGIN -- (E) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN FIVE " & + "MINUTES - 5"); + END IF; + + IF GLOBAL /= 5 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "TASK EXIT - 5"); + END IF; + + END; -- (E) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (F) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 5 * 60; -- FIVE MINUTE DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE ARR IS ARRAY (1..1) OF T2; + TYPE RAT; + TYPE ARAT IS ACCESS RAT; + TYPE RAT IS + RECORD + A : ARAT; + T : ARR; + END RECORD; + LIST : ARAT; + TEMP : ARAT; + BEGIN + FOR I IN 1 .. IDENT_INT (1) LOOP + TEMP := NEW RAT; + TEMP.A := LIST; + LIST := TEMP; + CALL_ENTRY (LIST.T(1), IDENT_INT(6)); + END LOOP; + END TSK; + + BEGIN -- (F) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN FIVE " & + "MINUTES - 6"); + END IF; + + IF GLOBAL /= 6 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "TASK EXIT - 6"); + END IF; + + END; -- (F) + + RESULT; +END C94002A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94002b.ada b/gcc/testsuite/ada/acats/tests/c9/c94002b.ada new file mode 100644 index 000000000..1f226f7c5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94002b.ada @@ -0,0 +1,208 @@ +-- C94002B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A MASTER UNIT, WHICH ALLOCATES TASKS OF A GLOBAL ACCESS +-- TYPE MAY TERMINATE WITHOUT WAITING FOR THE ALLOCATED TASKS TO +-- TERMINATE. + +-- SUBTESTS ARE: +-- (A) A SIMPLE TASK ALLOCATOR, IN A BLOCK. +-- (B) A RECORD OF TASK ALLOCATOR, IN A SUBPROGRAM. +-- (C) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A TASK BODY. + +-- JRK 10/8/81 +-- SPS 11/2/82 +-- SPS 11/21/82 +-- JRK 11/29/82 +-- TBN 1/20/86 REPLACED WITH C94006A-B.ADA AFTER LOWERING THE DELAY +-- VALUES, AND MODIFYING THE COMMENTS. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94002B IS + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + BEGIN + ACCEPT E; + ACCEPT E; + END TT; + + +BEGIN + TEST ("C94002B", "CHECK THAT A MASTER UNIT, WHICH ALLOCATES " & + "TASKS OF A GLOBAL ACCESS TYPE MAY TERMINATE " & + "WITHOUT WAITING FOR THE ALLOCATED TASKS TO " & + "TERMINATE"); + + -------------------------------------------------- + + DECLARE -- (A) + + TYPE A_T IS ACCESS TT; + A1 : A_T; + + BEGIN -- (A) + + DECLARE + A2 : A_T; + BEGIN + A2 := NEW TT; + A2.ALL.E; + A1 := A2; + END; + + IF A1.ALL'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED - (A)"); + END IF; + + A1.ALL.E; + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + + TYPE RT IS + RECORD + T : TT; + END RECORD; + TYPE ART IS ACCESS RT; + AR1 : ART; + + PROCEDURE P (AR : OUT ART) IS + AR2 : ART; + BEGIN + AR2 := NEW RT; + AR2.T.E; + AR := AR2; + END P; + + BEGIN + P (AR1); + + IF AR1.T'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " & + "- (B)"); + END IF; + + AR1.T.E; + RETURN 0; + END F; + + BEGIN -- (B) + + I := F; + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60; -- DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + + LOOP_COUNT1 : INTEGER := 0; + CUT_OFF1 : CONSTANT := 60; -- DELAY. + + TYPE RAT; + TYPE ARAT IS ACCESS RAT; + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RAT IS + RECORD + A : ARAT; + T : ARR; + END RECORD; + ARA1 : ARAT; + + TASK TSK1 IS + ENTRY ENT1 (ARA : OUT ARAT); + END TSK1; + + TASK BODY TSK1 IS + ARA2 : ARAT; + BEGIN + ARA2 := NEW RAT; + ARA2.T(1).E; + ACCEPT ENT1 (ARA : OUT ARAT) DO + ARA := ARA2; + END ENT1; + END TSK1; + + BEGIN + TSK1.ENT1 (ARA1); + + WHILE NOT TSK1'TERMINATED AND LOOP_COUNT1 < CUT_OFF1 LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT1 := LOOP_COUNT1 + 1; + END LOOP; + + IF LOOP_COUNT1 >= CUT_OFF1 THEN + FAILED ("DEPENDENT TASK TSK1 NOT TERMINATED " & + "WITHIN ONE MINUTE - (C)"); + END IF; + + IF ARA1.T(1)'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " & + "- (C)"); + END IF; + + ARA1.T(1).E; + END TSK; + + BEGIN -- (C) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 2.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK TSK NOT TERMINATED WITHIN " & + "TWO MINUTES - (C)"); + END IF; + + END; -- (C) + + -------------------------------------------------- + + RESULT; +END C94002B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94002d.ada b/gcc/testsuite/ada/acats/tests/c9/c94002d.ada new file mode 100644 index 000000000..372fac0bf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94002d.ada @@ -0,0 +1,74 @@ +-- C94002D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TASK DOES N O T DEPEND ON A UNIT IF IT IS DESIGNATED +-- BY A LOCAL ACCESS VARIABLE (OF THIS UNIT) WHOSE TYPE IS DECLARED +-- OUTSIDE THIS UNIT. + +-- WEI 3/ 4/82 +-- JBG 2/20/84 +-- TBN 11/25/85 RENAMED FROM C940ACB-B.ADA. + +WITH REPORT; + USE REPORT; +PROCEDURE C94002D IS + + TASK TYPE TT1 IS + ENTRY E1; + ENTRY E2; + END TT1; + + TYPE ATT1 IS ACCESS TT1; + OUTER_TT1 : ATT1; + + TASK BODY TT1 IS + BEGIN + ACCEPT E1; + ACCEPT E2; + END TT1; + +BEGIN + TEST ("C94002D", "DEPENDENCY IS INDEPENDENT OF WHERE ACCESS " & + "VARIABLE IS DECLARED"); + +BLOCK1 : + DECLARE + POINTER_TT1 : ATT1 := NEW TT1; + BEGIN + OUTER_TT1 := POINTER_TT1; + POINTER_TT1.ALL.E1; + END BLOCK1; -- MAY DEADLOCK HERE IF INCORRECT DEPENDENCY + -- RULE IS IMPLEMENTED. + + IF OUTER_TT1.ALL'TERMINATED THEN + FAILED ("NON-DEPENDENT TASK IS TERMINATED " & + "IMMEDIATELY AFTER ENCLOSING UNIT HAS " & + "BEEN COMPLETED"); + END IF; + + OUTER_TT1.E2; -- RELEASE TASK + + RESULT; + +END C94002D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94002e.ada b/gcc/testsuite/ada/acats/tests/c9/c94002e.ada new file mode 100644 index 000000000..940fd3289 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94002e.ada @@ -0,0 +1,207 @@ +-- C94002E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES TASKS OF A GLOBAL +-- ACCESS TYPE, MUST TERMINATE WITHOUT WAITING FOR THE ALLOCATED TASKS +-- TO TERMINATE. + +-- SUBTESTS ARE: +-- (A) A SIMPLE TASK ALLOCATOR, IN A BLOCK. +-- (B) A RECORD OF TASK ALLOCATOR, IN A SUBPROGRAM. +-- (C) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A TASK BODY. + +-- JRK 10/8/81 +-- SPS 11/2/82 +-- SPS 11/21/82 +-- JRK 11/29/82 +-- TBN 1/20/86 RENAMED FROM C94006A-B.ADA. LOWERED THE DELAY VALUES +-- AND MODIFIED THE COMMENTS. +-- JRK 5/1/86 IMPROVED ERROR RECOVERY LOGIC. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94002E IS + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + BEGIN + ACCEPT E; + ACCEPT E; + END TT; + + +BEGIN + TEST ("C94002E", "CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES " & + "TASKS OF A GLOBAL ACCESS TYPE, MUST TERMINATE " & + "WITHOUT WAITING FOR THE ALLOCATED TASKS TO " & + "TERMINATE"); + + -------------------------------------------------- + + DECLARE -- (A) + + TYPE A_T IS ACCESS TT; + A1 : A_T; + + BEGIN -- (A) + + DECLARE + A2 : A_T; + BEGIN + A2 := NEW TT; + A2.ALL.E; + A1 := A2; + END; + + IF A1.ALL'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED - (A)"); + ELSE A1.ALL.E; + END IF; + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + + TYPE RT IS + RECORD + T : TT; + END RECORD; + TYPE ART IS ACCESS RT; + AR1 : ART; + + PROCEDURE P (AR : OUT ART) IS + AR2 : ART; + BEGIN + AR2 := NEW RT; + AR2.T.E; + AR := AR2; + END P; + + BEGIN + P (AR1); + + IF AR1.T'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " & + "- (B)"); + ELSE AR1.T.E; + END IF; + + RETURN 0; + END F; + + BEGIN -- (B) + + I := F; + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60; -- DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + + LOOP_COUNT1 : INTEGER := 0; + CUT_OFF1 : CONSTANT := 60; -- DELAY. + + TYPE RAT; + TYPE ARAT IS ACCESS RAT; + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RAT IS + RECORD + A : ARAT; + T : ARR; + END RECORD; + ARA1 : ARAT; + + TASK TSK1 IS + ENTRY ENT1 (ARA : OUT ARAT); + END TSK1; + + TASK BODY TSK1 IS + ARA2 : ARAT; + BEGIN + ARA2 := NEW RAT; + ARA2.T(1).E; + ACCEPT ENT1 (ARA : OUT ARAT) DO + ARA := ARA2; + END ENT1; + END TSK1; + + BEGIN + TSK1.ENT1 (ARA1); + + WHILE NOT TSK1'TERMINATED AND LOOP_COUNT1 < CUT_OFF1 LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT1 := LOOP_COUNT1 + 1; + END LOOP; + + IF LOOP_COUNT1 >= CUT_OFF1 THEN + FAILED ("DEPENDENT TASK TSK1 NOT TERMINATED " & + "WITHIN ONE MINUTE - (C)"); + END IF; + + IF ARA1.T(1)'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " & + "- (C)"); + ELSE ARA1.T(1).E; + END IF; + END TSK; + + BEGIN -- (C) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 2.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK TSK NOT TERMINATED WITHIN " & + "TWO MINUTES - (C)"); + END IF; + + END; -- (C) + + -------------------------------------------------- + + RESULT; +END C94002E; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94002f.ada b/gcc/testsuite/ada/acats/tests/c9/c94002f.ada new file mode 100644 index 000000000..47f0b4df2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94002f.ada @@ -0,0 +1,227 @@ +-- C94002F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES TASKS OF A GLOBAL +-- ACCESS TYPE, MUST TERMINATE WITHOUT WAITING FOR THE ALLOCATED TASKS +-- TO TERMINATE IF AN EXCEPTION IS RAISED AND HANDLED IN THE +-- NON-MASTER UNIT. + +-- SUBTESTS ARE: +-- (A) A SIMPLE TASK ALLOCATOR, IN A BLOCK. +-- (B) A RECORD OF TASK ALLOCATOR, IN A SUBPROGRAM. +-- (C) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A TASK BODY. + +-- TBN 1/20/86 +-- JRK 5/1/86 IMPROVED ERROR RECOVERY. FIXED EXCEPTION HANDLING. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94002F IS + + MY_EXCEPTION : EXCEPTION; + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + BEGIN + ACCEPT E; + ACCEPT E; + END TT; + + +BEGIN + TEST ("C94002F", "CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES " & + "TASKS OF A GLOBAL ACCESS TYPE, MUST TERMINATE " & + "WITHOUT WAITING FOR THE ALLOCATED TASKS TO " & + "TERMINATE IF AN EXCEPTION IS RAISED AND " & + "HANDLED IN THE NON-MASTER UNIT"); + + -------------------------------------------------- + + DECLARE -- (A) + + TYPE A_T IS ACCESS TT; + A1 : A_T; + + BEGIN -- (A) + + DECLARE + A2 : A_T; + BEGIN + A2 := NEW TT; + A2.ALL.E; + A1 := A2; + RAISE MY_EXCEPTION; + FAILED ("MY_EXCEPTION WAS NOT RAISED IN (A)"); + EXCEPTION + WHEN MY_EXCEPTION => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION IN (A)"); + END; + + IF A1.ALL'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED - (A)"); + ELSE A1.ALL.E; + END IF; + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + + TYPE RT IS + RECORD + T : TT; + END RECORD; + TYPE ART IS ACCESS RT; + AR1 : ART; + + PROCEDURE P (AR : OUT ART) IS + AR2 : ART; + BEGIN + AR2 := NEW RT; + AR2.T.E; + AR := AR2; + RAISE MY_EXCEPTION; + FAILED ("MY_EXCEPTION WAS NOT RAISED IN (B)"); + EXCEPTION + WHEN MY_EXCEPTION => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION IN (B)"); + END P; + + BEGIN + P (AR1); + + IF AR1.T'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " & + "- (B)"); + ELSE AR1.T.E; + END IF; + + RETURN 0; + END F; + + BEGIN -- (B) + + I := F; + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60; -- DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + + LOOP_COUNT1 : INTEGER := 0; + CUT_OFF1 : CONSTANT := 60; -- DELAY. + + TYPE RAT; + TYPE ARAT IS ACCESS RAT; + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RAT IS + RECORD + A : ARAT; + T : ARR; + END RECORD; + ARA1 : ARAT; + + TASK TSK1 IS + ENTRY ENT1 (ARA : OUT ARAT); + END TSK1; + + TASK BODY TSK1 IS + ARA2 : ARAT; + BEGIN + ARA2 := NEW RAT; -- INITIATE TASK ARA2.T(1). + ARA2.T(1).E; + ACCEPT ENT1 (ARA : OUT ARAT) DO + ARA := ARA2; + END ENT1; + RAISE MY_EXCEPTION; + FAILED ("MY_EXCEPTION WAS NOT RAISED IN (C)"); + EXCEPTION + WHEN MY_EXCEPTION => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION IN (C)"); + END TSK1; + + BEGIN + TSK1.ENT1 (ARA1); -- ARA1.T BECOMES ALIAS FOR ARA2.T. + + WHILE NOT TSK1'TERMINATED AND LOOP_COUNT1 < CUT_OFF1 LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT1 := LOOP_COUNT1 + 1; + END LOOP; + + IF LOOP_COUNT1 >= CUT_OFF1 THEN + FAILED ("DEPENDENT TASK TSK1 NOT TERMINATED " & + "WITHIN ONE MINUTE - (C)"); + END IF; + + IF ARA1.T(1)'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " & + "- (C)"); + ELSE ARA1.T(1).E; + END IF; + END TSK; + + BEGIN -- (C) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 2.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK TSK NOT TERMINATED WITHIN " & + "TWO MINUTES - (C)"); + END IF; + + END; -- (C) + + --------------------------------------------------------------- + + RESULT; +END C94002F; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94002g.ada b/gcc/testsuite/ada/acats/tests/c9/c94002g.ada new file mode 100644 index 000000000..1b6108fe5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94002g.ada @@ -0,0 +1,350 @@ +-- C94002G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES TASKS OF A GLOBAL +-- ACCESS TYPE, MUST TERMINATE WITHOUT WAITING FOR THE ALLOCATED +-- TASKS TO TERMINATE IF AN EXCEPTION IS RAISED BUT NOT HANDLED IN +-- THE NON-MASTER UNIT. + +-- SUBTESTS ARE: +-- (A) A SIMPLE TASK ALLOCATOR, IN A BLOCK. +-- (B) A RECORD OF TASK ALLOCATOR, IN A SUBPROGRAM. +-- (C) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A TASK BODY, NOT +-- DURING RENDEZVOUS. +-- (D) A LIMITED PRIVATE TASK ALLOCATOR, IN A TASK BODY, DURING +-- RENDEZVOUS. + +-- HISTORY: +-- TBN 01/20/86 CREATED ORIGINAL TEST. +-- JRK 05/01/86 IMPROVED ERROR RECOVERY. FIXED EXCEPTION +-- HANDLING. ADDED CASE (D). +-- BCB 09/24/87 ADDED A RETURN STATEMENT TO THE HANDLER FOR OTHERS +-- IN FUNCTION F, CASE B. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94002G IS + + MY_EXCEPTION : EXCEPTION; + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + BEGIN + ACCEPT E; + ACCEPT E; + END TT; + + +BEGIN + TEST ("C94002G", "CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES " & + "TASKS OF A GLOBAL ACCESS TYPE, MUST TERMINATE " & + "WITHOUT WAITING FOR THE ALLOCATED TASKS TO " & + "TERMINATE IF AN EXCEPTION IS RAISED BUT NOT " & + "HANDLED IN THE NON-MASTER UNIT"); + + -------------------------------------------------- + + DECLARE -- (A) + + TYPE A_T IS ACCESS TT; + A1 : A_T; + + BEGIN -- (A) + + DECLARE + A2 : A_T; + BEGIN + A2 := NEW TT; + A2.ALL.E; + A1 := A2; + RAISE MY_EXCEPTION; + FAILED ("MY_EXCEPTION WAS NOT RAISED IN (A)"); + END; + + ABORT A1.ALL; + + EXCEPTION + WHEN MY_EXCEPTION => + IF A1.ALL'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED - " & + "(A)"); + ELSE A1.ALL.E; + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION IN (A)"); + IF A1 /= NULL THEN + ABORT A1.ALL; + END IF; + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + + TYPE RT IS + RECORD + T : TT; + END RECORD; + TYPE ART IS ACCESS RT; + AR1 : ART; + + PROCEDURE P IS + AR2 : ART; + BEGIN + AR2 := NEW RT; + AR2.T.E; + AR1 := AR2; + RAISE MY_EXCEPTION; + FAILED ("MY_EXCEPTION WAS NOT RAISED IN (B)"); + END P; + + BEGIN + P; + ABORT AR1.T; + RETURN 0; + EXCEPTION + WHEN MY_EXCEPTION => + IF AR1.T'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY " & + "TERMINATED - (B)"); + ELSE AR1.T.E; + END IF; + RETURN 0; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION IN (B)"); + IF AR1 /= NULL THEN + ABORT AR1.T; + END IF; + RETURN 0; + END F; + + BEGIN -- (B) + + I := F; + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60; -- DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + + LOOP_COUNT1 : INTEGER := 0; + CUT_OFF1 : CONSTANT := 60; -- DELAY. + + TYPE RAT; + TYPE ARAT IS ACCESS RAT; + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RAT IS + RECORD + A : ARAT; + T : ARR; + END RECORD; + ARA1 : ARAT; + + TASK TSK1 IS + ENTRY ENT1 (ARA : OUT ARAT); + END TSK1; + + TASK BODY TSK1 IS + ARA2 : ARAT; + BEGIN + ARA2 := NEW RAT; -- INITIATE TASK ARA2.T(1). + ARA2.T(1).E; + ACCEPT ENT1 (ARA : OUT ARAT) DO + ARA := ARA2; + END ENT1; + RAISE MY_EXCEPTION; -- NOT PROPOGATED. + FAILED ("MY_EXCEPTION WAS NOT RAISED IN (C)"); + END TSK1; + + BEGIN + TSK1.ENT1 (ARA1); -- ARA1.T BECOMES ALIAS FOR ARA2.T. + + WHILE NOT TSK1'TERMINATED AND LOOP_COUNT1 < CUT_OFF1 LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT1 := LOOP_COUNT1 + 1; + END LOOP; + + IF LOOP_COUNT1 >= CUT_OFF1 THEN + FAILED ("DEPENDENT TASK TSK1 NOT TERMINATED " & + "WITHIN ONE MINUTE - (C)"); + END IF; + + IF ARA1.T(1)'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " & + "- (C)"); + ELSE ARA1.T(1).E; + END IF; + END TSK; + + BEGIN -- (C) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 2.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK TSK NOT TERMINATED WITHIN " & + "TWO MINUTES - (C)"); + END IF; + + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60; -- DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + + LOOP_COUNT1 : INTEGER := 0; + CUT_OFF1 : CONSTANT := 60; -- DELAY. + + PACKAGE PKG IS + TYPE LPT IS LIMITED PRIVATE; + PROCEDURE CALL (X : LPT); + PROCEDURE KILL (X : LPT); + FUNCTION TERMINATED (X : LPT) RETURN BOOLEAN; + PRIVATE + TYPE LPT IS NEW TT; + END PKG; + + USE PKG; + + TYPE ALPT IS ACCESS LPT; + ALP1 : ALPT; + + PACKAGE BODY PKG IS + PROCEDURE CALL (X : LPT) IS + BEGIN + X.E; + END CALL; + + PROCEDURE KILL (X : LPT) IS + BEGIN + ABORT X; + END KILL; + + FUNCTION TERMINATED (X : LPT) RETURN BOOLEAN IS + BEGIN + RETURN X'TERMINATED; + END TERMINATED; + END PKG; + + TASK TSK1 IS + ENTRY ENT1 (ALP : OUT ALPT); + ENTRY DIE; + END TSK1; + + TASK BODY TSK1 IS + ALP2 : ALPT; + BEGIN + ALP2 := NEW LPT; -- INITIATE TASK ALP2.ALL. + CALL (ALP2.ALL); + ACCEPT ENT1 (ALP : OUT ALPT) DO + ALP := ALP2; + END ENT1; + ACCEPT DIE DO + RAISE MY_EXCEPTION; -- PROPOGATED. + FAILED ("MY_EXCEPTION WAS NOT RAISED IN (D)"); + END DIE; + END TSK1; + + BEGIN + TSK1.ENT1 (ALP1); -- ALP1.ALL BECOMES ALIAS FOR ALP2.ALL. + TSK1.DIE; + FAILED ("MY_EXCEPTION WAS NOT PROPOGATED TO CALLING " & + "TASK - (D)"); + KILL (ALP1.ALL); + ABORT TSK1; + EXCEPTION + WHEN MY_EXCEPTION => + WHILE NOT TSK1'TERMINATED AND + LOOP_COUNT1 < CUT_OFF1 LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT1 := LOOP_COUNT1 + 1; + END LOOP; + + IF LOOP_COUNT1 >= CUT_OFF1 THEN + FAILED ("DEPENDENT TASK TSK1 NOT TERMINATED " & + "WITHIN ONE MINUTE - (D)"); + END IF; + + IF TERMINATED (ALP1.ALL) THEN + FAILED ("ALLOCATED TASK PREMATURELY " & + "TERMINATED - (D)"); + ELSE CALL (ALP1.ALL); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION IN (D)"); + IF ALP1 /= NULL THEN + KILL (ALP1.ALL); + END IF; + ABORT TSK1; + END TSK; + + BEGIN -- (D) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 2.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK TSK NOT TERMINATED WITHIN " & + "TWO MINUTES - (D)"); + END IF; + + END; -- (D) + + -------------------------------------------------- + + RESULT; +END C94002G; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94004a.ada b/gcc/testsuite/ada/acats/tests/c9/c94004a.ada new file mode 100644 index 000000000..b895f8c87 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94004a.ada @@ -0,0 +1,95 @@ +-- C94004A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A MAIN PROGRAM TERMINATES WITHOUT WAITING FOR TASKS THAT +-- DEPEND ON A LIBRARY PACKAGE AND THAT SUCH TASKS ARE NOT TERMINATED BY +-- MAIN PROGRAM TERMINATION. + +-- CASE A: TASK OBJECT DECLARED IN LIBRARY PACKAGE USED BY MAIN +-- PROGRAM. + +-- JRK 10/8/81 +-- SPS 11/21/82 +-- JBG 12/6/84 +-- JRK 11/21/85 RENAMED FROM C94004A-B.ADA; REVISED ACCORDING TO +-- AI-00399. +-- JRK 10/24/86 RENAMED FROM E94004A-B.ADA; REVISED ACCORDING TO +-- REVISED AI-00399. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +WITH SYSTEM; USE SYSTEM; +PACKAGE C94004A_PKG IS + + TASK TYPE TT IS + ENTRY E; + END TT; + +END C94004A_PKG; + +with Impdef; +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +PACKAGE BODY C94004A_PKG IS + + TASK BODY TT IS + I : INTEGER := IDENT_INT (120); + BEGIN + ACCEPT E; + COMMENT ("DELAY LIBRARY TASK FOR TWO MINUTES"); + DELAY DURATION(I) * Impdef.One_Second; + -- MAIN PROGRAM SHOULD NOW BE TERMINATED. + RESULT; + END TT; + +END C94004A_PKG; + +WITH C94004A_PKG; USE C94004A_PKG; +PRAGMA ELABORATE (C94004A_PKG); +PACKAGE C94004A_TASK IS + T : TT; +END; + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +WITH C94004A_TASK; +PROCEDURE C94004A IS + + +BEGIN + TEST ("C94004A", "CHECK THAT A MAIN PROGRAM TERMINATES " & + "WITHOUT WAITING FOR TASKS THAT DEPEND " & + "ON A LIBRARY PACKAGE AND THAT SUCH TASKS " & + "CONTINUE TO EXECUTE"); + + COMMENT ("THE INVOKING SYSTEM'S JOB CONTROL LOG MUST BE " & + "EXAMINED TO SEE IF THIS TEST REALLY TERMINATES"); + + C94004A_TASK.T.E; -- ALLOW TASK TO PROCEED. + IF C94004A_TASK.T'TERMINATED THEN + FAILED ("LIBRARY DECLARED TASK PREMATURELY TERMINATED"); + END IF; + + -- RESULT PROCEDURE IS CALLED BY LIBRARY TASK. + +END C94004A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94004b.ada b/gcc/testsuite/ada/acats/tests/c9/c94004b.ada new file mode 100644 index 000000000..3a578fd8b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94004b.ada @@ -0,0 +1,97 @@ +-- C94004B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A MAIN PROGRAM TERMINATES WITHOUT WAITING FOR TASKS THAT +-- DEPEND ON A LIBRARY PACKAGE AND THAT SUCH TASKS ARE NOT TERMINATED BY +-- MAIN PROGRAM TERMINATION. + +-- CASE B: ACCESS TO TASK TYPE DECLARED IN LIBRARY PACKAGE; TASK +-- ACTIVATED IN MAIN PROGRAM. + +-- JRK 10/8/81 +-- SPS 11/21/82 +-- JBG 12/6/84 +-- JRK 11/21/85 RENAMED FROM C94004B-B.ADA; REVISED ACCORDING TO +-- AI-00399. +-- JRK 10/24/86 RENAMED FROM E94004B-B.ADA; REVISED ACCORDING TO +-- REVISED AI-00399. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +WITH SYSTEM; USE SYSTEM; +PACKAGE C94004B_PKG IS + + TASK TYPE TT IS + ENTRY E; + END TT; + +END C94004B_PKG; + +with Impdef; +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +PACKAGE BODY C94004B_PKG IS + + TASK BODY TT IS + I : INTEGER := IDENT_INT (120); + BEGIN + ACCEPT E; + COMMENT ("DELAY LIBRARY TASK FOR TWO MINUTES"); + DELAY DURATION(I) * Impdef.One_Second; + -- MAIN PROGRAM SHOULD NOW BE TERMINATED. + RESULT; + END TT; + +END C94004B_PKG; + +WITH C94004B_PKG; USE C94004B_PKG; +PRAGMA ELABORATE (C94004B_PKG); +PACKAGE C94004B_TASK IS + TYPE ACC_TASK IS ACCESS C94004B_PKG.TT; +END; + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +WITH C94004B_TASK; WITH C94004B_PKG; +PROCEDURE C94004B IS + + T : C94004B_TASK.ACC_TASK; + +BEGIN + TEST ("C94004B", "CHECK THAT A MAIN PROGRAM TERMINATES " & + "WITHOUT WAITING FOR TASKS THAT DEPEND " & + "ON A LIBRARY PACKAGE AND THAT SUCH TASKS " & + "CONTINUE TO EXECUTE"); + + COMMENT ("THE INVOKING SYSTEM'S JOB CONTROL LOG MUST BE " & + "EXAMINED TO SEE IF THIS TEST REALLY TERMINATES"); + + T := NEW C94004B_PKG.TT; + T.E; -- ALLOW TASK TO PROCEED. + IF T'TERMINATED THEN + FAILED ("LIBRARY DECLARED TASK PREMATURELY TERMINATED"); + END IF; + + -- RESULT PROCEDURE IS CALLED BY LIBRARY TASK. + +END C94004B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94004c.ada b/gcc/testsuite/ada/acats/tests/c9/c94004c.ada new file mode 100644 index 000000000..321bfee72 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94004c.ada @@ -0,0 +1,104 @@ +-- C94004C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A MAIN PROGRAM TERMINATES WITHOUT WAITING FOR TASKS THAT +-- DEPEND ON A LIBRARY PACKAGE AND THAT SUCH TASKS ARE NOT TERMINATED BY +-- MAIN PROGRAM TERMINATION. + +-- CASE C: TASK OBJECT DECLARED IN LIBRARY PACKAGE USED BY MAIN PROGRAM +-- AND WAITING AT A SELECTIVE WAIT WITH TERMINATE. + +-- JRK 10/8/81 +-- SPS 11/21/82 +-- JBG 12/6/84 +-- JRK 11/21/85 RENAMED FROM C94004C-B.ADA; REVISED ACCORDING TO +-- AI-00399. +-- JRK 10/24/86 RENAMED FROM E94004C-B.ADA; REVISED ACCORDING TO +-- REVISED AI-00399. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +WITH SYSTEM; USE SYSTEM; +PACKAGE C94004C_PKG IS + + TASK TYPE TT IS + ENTRY E; + END TT; + +END C94004C_PKG; + +with Impdef; +WITH REPORT; USE REPORT; +PRAGMA ELABORATE (REPORT); +PACKAGE BODY C94004C_PKG IS + + TASK BODY TT IS + I : INTEGER := IDENT_INT (120); + BEGIN + ACCEPT E; + COMMENT ("DELAY LIBRARY TASK FOR TWO MINUTES"); + DELAY DURATION(I) * Impdef.One_Second; + -- MAIN PROGRAM SHOULD NOW BE TERMINATED. + RESULT; + -- USE LOOP FOR SELECTIVE WAIT WITH TERMINATE. + LOOP + SELECT + ACCEPT E; + OR + TERMINATE; + END SELECT; + END LOOP; + -- FAILS IF JOB HANGS UP WITHOUT TERMINATING. + END TT; + +END C94004C_PKG; + +WITH C94004C_PKG; USE C94004C_PKG; +PRAGMA ELABORATE (C94004C_PKG); +PACKAGE C94004C_TASK IS + T : TT; +END; + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +WITH C94004C_TASK; +PROCEDURE C94004C IS + + +BEGIN + TEST ("C94004C", "CHECK THAT A MAIN PROGRAM TERMINATES " & + "WITHOUT WAITING FOR TASKS THAT DEPEND " & + "ON A LIBRARY PACKAGE AND THAT SUCH TASKS " & + "CONTINUE TO EXECUTE"); + + COMMENT ("THE INVOKING SYSTEM'S JOB CONTROL LOG MUST BE " & + "EXAMINED TO SEE IF THIS TEST REALLY TERMINATES"); + + C94004C_TASK.T.E; -- ALLOW TASK TO PROCEED. + IF C94004C_TASK.T'TERMINATED THEN + FAILED ("LIBRARY DECLARED TASK PREMATURELY TERMINATED"); + END IF; + + -- RESULT PROCEDURE IS CALLED BY LIBRARY TASK. + +END C94004C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94005a.ada b/gcc/testsuite/ada/acats/tests/c9/c94005a.ada new file mode 100644 index 000000000..71c5846f4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94005a.ada @@ -0,0 +1,90 @@ +-- C94005A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF A TASK TYPE IS DECLARED IN A LIBRARY PACKAGE, A MAIN +-- PROGRAM THAT DECLARES OBJECTS OF THAT TYPE DOES WAIT FOR +-- TERMINATION OF SUCH OBJECTS. + +-- THIS TEST CONTAINS RACE CONDITIONS. + +-- JRK 10/8/81 +-- SPS 11/21/82 +-- JWC 11/15/85 MADE THE LIBRARY PACKAGE NAME UNIQUE, C94005A_PKG. +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + +WITH SYSTEM; USE SYSTEM; +PACKAGE C94005A_PKG IS + + TASK TYPE TT IS + ENTRY E; + END TT; + +END C94005A_PKG; + +with Impdef; +WITH REPORT; USE REPORT; +PACKAGE BODY C94005A_PKG IS + + TASK BODY TT IS + I : INTEGER := IDENT_INT (0); + BEGIN + ACCEPT E; + FOR J IN 1..60 LOOP + I := IDENT_INT (I); + DELAY 1.0 * Impdef.One_Second; + END LOOP; + RESULT; -- FAILURE IF THIS MESSAGE IS NOT WRITTEN. + END TT; + +END C94005A_PKG; + + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +WITH C94005A_PKG; +PROCEDURE C94005A IS + + T : C94005A_PKG.TT; + + +BEGIN + TEST ("C94005A", "CHECK THAT IF A TASK TYPE IS DECLARED IN A " & + "LIBRARY PACKAGE, A MAIN PROGRAM THAT " & + "DECLARES OBJECTS OF THAT TYPE DOES WAIT FOR " & + "TERMINATION OF SUCH OBJECTS"); + + COMMENT ("THE INVOKING SYSTEM'S JOB CONTROL LOG MUST BE " & + "EXAMINED TO SEE IF THIS TEST REALLY TERMINATES"); + + T.E; + + IF T'TERMINATED THEN + COMMENT ("TEST INCONCLUSIVE BECAUSE TASK T PREMATURELY " & + "TERMINATED"); + END IF; + + -- TASK T SHOULD WRITE THE RESULT MESSAGE. + +END C94005A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94005b.ada b/gcc/testsuite/ada/acats/tests/c9/c94005b.ada new file mode 100644 index 000000000..2a481b313 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94005b.ada @@ -0,0 +1,168 @@ +-- C94005B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF A TASK TYPE IS DECLARED IN A LIBRARY PACKAGE, ANY +-- BLOCKS, SUBPROGRAMS, OR TASKS THAT DECLARE OBJECTS OF THAT TYPE +-- DO WAIT FOR TERMINATION OF SUCH OBJECTS. +-- SUBTESTS ARE: +-- (A) IN A MAIN PROGRAM BLOCK. +-- (B) IN A LIBRARY FUNCTION. +-- (C) IN A MAIN PROGRAM TASK BODY. + +-- THIS TEST CONTAINS SHARED VARIABLES AND RACE CONDITIONS. + +-- JRK 10/8/81 +-- SPS 11/2/82 +-- SPS 11/21/82 +-- JWC 11/15/85 MADE THE LIBRARY PACKAGE NAME UNIQUE, C94005B_PKG. +-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + +WITH SYSTEM; USE SYSTEM; +PACKAGE C94005B_PKG IS + + GLOBAL : INTEGER; + + TASK TYPE TT IS + ENTRY E (I : INTEGER); + END TT; + +END C94005B_PKG; + +with Impdef; +PACKAGE BODY C94005B_PKG IS + + TASK BODY TT IS + LOCAL : INTEGER; + BEGIN + ACCEPT E (I : INTEGER) DO + LOCAL := I; + END E; + DELAY 60.0 * Impdef.One_Second; -- SINCE THE PARENT UNIT HAS HIGHER PRIORITY + -- AT THIS POINT, IT WILL RECEIVE CONTROL AND + -- TERMINATE IF THE ERROR IS PRESENT. + GLOBAL := LOCAL; + END TT; + +END C94005B_PKG; + + +WITH REPORT; USE REPORT; +WITH C94005B_PKG; USE C94005B_PKG; +FUNCTION F RETURN INTEGER IS + + T : TT; + +BEGIN + + T.E (IDENT_INT(2)); + RETURN 0; + +END F; + +with Impdef; +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +WITH C94005B_PKG; USE C94005B_PKG; +WITH F; +PROCEDURE C94005B IS + + +BEGIN + TEST ("C94005B", "CHECK THAT IF A TASK TYPE IS DECLARED IN A " & + "LIBRARY PACKAGE, ANY BLOCKS, SUBPROGRAMS, OR " & + "TASKS THAT DECLARE OBJECTS OF THAT TYPE DO " & + "WAIT FOR TERMINATION OF SUCH OBJECTS"); + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (A) + + T : TT; + + BEGIN -- (A) + + T.E (IDENT_INT(1)); + + END; -- (A) + + IF GLOBAL /= 1 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - (A)"); + END IF; + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (B) + + I : INTEGER; + + BEGIN -- (B) + + I := F ; + + IF GLOBAL /= 2 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - (B)"); + END IF; + + END; -- (B) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C) + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + T : TT; + BEGIN + T.E (IDENT_INT(3)); + END TSK; + + BEGIN -- (C) + + WHILE NOT TSK'TERMINATED LOOP + DELAY 0.1 * Impdef.One_Second; + END LOOP; + + IF GLOBAL /= 3 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "TASK EXIT - (C)"); + END IF; + + END; -- (C) + + -------------------------------------------------- + + RESULT; +END C94005B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94006a.ada b/gcc/testsuite/ada/acats/tests/c9/c94006a.ada new file mode 100644 index 000000000..cac5fc6e0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94006a.ada @@ -0,0 +1,136 @@ +-- C94006A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A DECLARATION THAT RENAMES A TASK DOES NOT CREATE A NEW +-- MASTER FOR THE TASK. + +-- TBN 9/17/86 +-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94006A IS + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + BEGIN + SELECT + ACCEPT E; + OR + DELAY 30.0 * Impdef.One_Long_Second; + END SELECT; + END TT; + + +BEGIN + TEST ("C94006A", "CHECK THAT A DECLARATION THAT RENAMES A TASK " & + "DOES NOT CREATE A NEW MASTER FOR THE TASK"); + + ------------------------------------------------------------------- + DECLARE + T1 : TT; + BEGIN + DECLARE + RENAME_TASK : TT RENAMES T1; + BEGIN + NULL; + END; + IF T1'TERMINATED THEN + FAILED ("TASK DEPENDENT ON WRONG UNIT - 1"); + ELSE + T1.E; + END IF; + END; + + ------------------------------------------------------------------- + + DECLARE + T2 : TT; + + PACKAGE P IS + Q : TT RENAMES T2; + END P; + + PACKAGE BODY P IS + BEGIN + NULL; + END P; + + USE P; + BEGIN + IF Q'TERMINATED THEN + FAILED ("TASK DEPENDENT ON WRONG UNIT - 2"); + ELSE + Q.E; + END IF; + END; + + ------------------------------------------------------------------- + + DECLARE + TYPE ACC_TT IS ACCESS TT; + P1 : ACC_TT; + BEGIN + DECLARE + RENAME_ACCESS : ACC_TT RENAMES P1; + BEGIN + RENAME_ACCESS := NEW TT; + END; + IF P1'TERMINATED THEN + FAILED ("TASK DEPENDENT ON WRONG UNIT - 3"); + ELSE + P1.E; + END IF; + END; + + ------------------------------------------------------------------- + + DECLARE + TYPE ACC_TT IS ACCESS TT; + P2 : ACC_TT; + + PACKAGE Q IS + RENAME_ACCESS : ACC_TT RENAMES P2; + END Q; + + PACKAGE BODY Q IS + BEGIN + RENAME_ACCESS := NEW TT; + END Q; + + USE Q; + BEGIN + IF RENAME_ACCESS'TERMINATED THEN + FAILED ("TASK DEPENDENT ON WRONG UNIT - 4"); + ELSE + RENAME_ACCESS.E; + END IF; + END; + + RESULT; +END C94006A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94007a.ada b/gcc/testsuite/ada/acats/tests/c9/c94007a.ada new file mode 100644 index 000000000..e0a2c3f76 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94007a.ada @@ -0,0 +1,270 @@ +-- C94007A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT A TASK THAT IS DECLARED IN A NON-LIBRARY PACKAGE +-- (SPECIFICATION OR BODY) DOES NOT "DEPEND" ON THE PACKAGE, +-- BUT ON THE INNERMOST ENCLOSING BLOCK, SUBPROGRAM BODY, +-- OR TASK BODY. +-- SUBTESTS ARE: +-- (A) A SIMPLE TASK OBJECT, IN A VISIBLE PART, IN A BLOCK. +-- (B) AN ARRAY OF TASK OBJECT, IN A PRIVATE PART, IN A FUNCTION. +-- (C) AN ARRAY OF RECORD OF TASK OBJECT, IN A PACKAGE BODY, +-- IN A TASK BODY. + +-- HISTORY: +-- JRK 10/13/81 +-- SPS 11/21/82 +-- DHH 09/07/88 REVISED HEADER, ADDED EXCEPTION HANDLERS ON OUTER +-- BLOCKS, AND ADDED CASE TO INSURE THAT LEAVING A +-- PACKAGE VIA AN EXCEPTION WOULD NOT ABORT TASKS. +-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94007A IS + + TASK TYPE SYNC IS + ENTRY ID (C : CHARACTER); + ENTRY INNER; + ENTRY OUTER; + END SYNC; + + TASK BODY SYNC IS + ID_C : CHARACTER; + BEGIN + ACCEPT ID (C : CHARACTER) DO + ID_C := C; + END ID; + DELAY 1.0 * Impdef.One_Second; + SELECT + ACCEPT OUTER; + OR + DELAY 120.0 * Impdef.One_Second; + FAILED ("PROBABLY BLOCKED - (" & ID_C & ')'); + END SELECT; + ACCEPT INNER; + END SYNC; + + +BEGIN + TEST ("C94007A", "CHECK THAT A TASK THAT IS DECLARED IN A " & + "NON-LIBRARY PACKAGE (SPECIFICATION OR BODY) " & + "DOES NOT ""DEPEND"" ON THE PACKAGE, BUT ON " & + "THE INNERMOST ENCLOSING BLOCK, SUBPROGRAM " & + "BODY, OR TASK BODY"); + + -------------------------------------------------- + + DECLARE -- (A) + + S : SYNC; + + BEGIN -- (A) + + S.ID ('A'); + + DECLARE + + PACKAGE PKG IS + TASK T IS + ENTRY E; + END T; + END PKG; + + PACKAGE BODY PKG IS + TASK BODY T IS + BEGIN + S.INNER; -- PROBABLE INNER BLOCK POINT. + END T; + END PKG; -- PROBABLE OUTER BLOCK POINT. + + BEGIN + + S.OUTER; + + EXCEPTION + WHEN TASKING_ERROR => NULL; + END; + + EXCEPTION + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED - A"); + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + S : SYNC; + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + + PACKAGE PKG IS + PRIVATE + TASK TYPE TT IS + ENTRY E; + END TT; + A : ARRAY (1..1) OF TT; + END PKG; + + PACKAGE BODY PKG IS + TASK BODY TT IS + BEGIN + S.INNER; -- PROBABLE INNER BLOCK POINT. + END TT; + END PKG; -- PROBABLE OUTER BLOCK POINT. + + BEGIN -- F + + S.OUTER; + RETURN 0; + + EXCEPTION + WHEN TASKING_ERROR => RETURN 0; + END F; + + BEGIN -- (B) + + S.ID ('B'); + I := F; + + EXCEPTION + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED - B"); + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + S : SYNC; + + BEGIN -- (C) + + S.ID ('C'); + + DECLARE + + TASK TSK IS + END TSK; + + TASK BODY TSK IS + + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + TASK TYPE TT IS + ENTRY E; + END TT; + + TYPE RT IS + RECORD + T : TT; + END RECORD; + + AR : ARRAY (1..1) OF RT; + + TASK BODY TT IS + BEGIN + S.INNER; -- PROBABLE INNER BLOCK POINT. + END TT; + END PKG; -- PROBABLE OUTER BLOCK POINT. + + BEGIN -- TSK + + S.OUTER; + + EXCEPTION + WHEN TASKING_ERROR => NULL; + END TSK; + + BEGIN + NULL; + END; + + EXCEPTION + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED - C"); + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D) + + GLOBAL : INTEGER := IDENT_INT(5); + + BEGIN -- (D) + + DECLARE + + PACKAGE PKG IS + TASK T IS + ENTRY E; + END T; + + TASK T1 IS + END T1; + END PKG; + + PACKAGE BODY PKG IS + TASK BODY T IS + BEGIN + ACCEPT E DO + RAISE CONSTRAINT_ERROR; + END E; + END T; + + TASK BODY T1 IS + BEGIN + DELAY 120.0 * Impdef.One_Second; + GLOBAL := IDENT_INT(1); + END T1; + + BEGIN + T.E; + + END PKG; + USE PKG; + BEGIN + NULL; + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF GLOBAL /= IDENT_INT(1) THEN + FAILED("TASK NOT COMPLETED"); + END IF; + + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED - D"); + END; -- (D) + + RESULT; +END C94007A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94007b.ada b/gcc/testsuite/ada/acats/tests/c9/c94007b.ada new file mode 100644 index 000000000..87e45b352 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94007b.ada @@ -0,0 +1,224 @@ +-- C94007B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TASK THAT IS ALLOCATED IN A NON-LIBRARY PACKAGE +-- (SPECIFICATION OR BODY) DOES NOT "DEPEND" ON THE PACKAGE, +-- BUT ON THE INNERMOST ENCLOSING BLOCK, SUBPROGRAM BODY, +-- OR TASK BODY. +-- SUBTESTS ARE: +-- (A) A SIMPLE TASK ALLOCATOR, IN A VISIBLE PART, IN A BLOCK. +-- (B) A RECORD OF TASK ALLOCATOR, IN A PRIVATE PART, IN A FUNCTION. +-- (C) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A PACKAGE BODY, +-- IN A TASK BODY. + +-- JRK 10/16/81 +-- SPS 11/2/82 +-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94007B IS + + TASK TYPE SYNC IS + ENTRY ID (C : CHARACTER); + ENTRY INNER; + ENTRY OUTER; + END SYNC; + + TASK BODY SYNC IS + ID_C : CHARACTER; + BEGIN + ACCEPT ID (C : CHARACTER) DO + ID_C := C; + END ID; + DELAY 1.0 * Impdef.One_Second; + SELECT + ACCEPT OUTER; + OR + DELAY 120.0 * Impdef.One_Second; + FAILED ("PROBABLY BLOCKED - (" & ID_C & ')'); + END SELECT; + ACCEPT INNER; + END SYNC; + + +BEGIN + TEST ("C94007B", "CHECK THAT A TASK THAT IS ALLOCATED IN A " & + "NON-LIBRARY PACKAGE (SPECIFICATION OR BODY) " & + "DOES NOT ""DEPEND"" ON THE PACKAGE, BUT ON " & + "THE INNERMOST ENCLOSING BLOCK, SUBPROGRAM " & + "BODY, OR TASK BODY"); + + -------------------------------------------------- + + DECLARE -- (A) + + S : SYNC; + + BEGIN -- (A) + + S.ID ('A'); + + DECLARE + + PACKAGE PKG IS + TASK TYPE TT IS + ENTRY E; + END TT; + TYPE A_T IS ACCESS TT; + A : A_T; + END PKG; + + PACKAGE BODY PKG IS + TASK BODY TT IS + BEGIN + S.INNER; -- PROBABLE INNER BLOCK POINT. + END TT; + BEGIN + A := NEW TT; + END PKG; -- PROBABLE OUTER BLOCK POINT. + + BEGIN + + S.OUTER; + + EXCEPTION + WHEN TASKING_ERROR => NULL; + END; + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + S : SYNC; + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + + PACKAGE PKG IS + PRIVATE + TASK TYPE TT IS + ENTRY E; + END TT; + + TYPE RT IS + RECORD + T : TT; + END RECORD; + + TYPE ART IS ACCESS RT; + + AR : ART; + END PKG; + + PACKAGE BODY PKG IS + TASK BODY TT IS + BEGIN + S.INNER; -- PROBABLE INNER BLOCK POINT. + END TT; + BEGIN + AR := NEW RT; + END PKG; -- PROBABLE OUTER BLOCK POINT. + + BEGIN -- F + + S.OUTER; + RETURN 0; + + EXCEPTION + WHEN TASKING_ERROR => RETURN 0; + END F; + + BEGIN -- (B) + + S.ID ('B'); + I := F ; + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + S : SYNC; + + BEGIN -- (C) + + S.ID ('C'); + + DECLARE + + TASK TSK IS + END TSK; + + TASK BODY TSK IS + + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + TASK TYPE TT IS + ENTRY E; + END TT; + + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RAT IS + RECORD + T : ARR; + END RECORD; + + TYPE ARAT IS ACCESS RAT; + + ARA : ARAT; + + TASK BODY TT IS + BEGIN + S.INNER; -- PROBABLE INNER BLOCK POINT. + END TT; + BEGIN + ARA := NEW RAT; + END PKG; -- PROBABLE OUTER BLOCK POINT. + + BEGIN -- TSK + + S.OUTER; + + EXCEPTION + WHEN TASKING_ERROR => NULL; + END TSK; + + BEGIN + NULL; + END; + + END; -- (C) + + -------------------------------------------------- + + RESULT; +END C94007B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94008a.ada b/gcc/testsuite/ada/acats/tests/c9/c94008a.ada new file mode 100644 index 000000000..90b31d315 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94008a.ada @@ -0,0 +1,61 @@ +-- C94008A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TASK WAITING AT AN OPEN TERMINATE ALTERNATIVE +-- DOES N O T TERMINATE WHILE THE UNIT THE TASK DEPENDS ON +-- HAS NOT COMPLETED ITS EXECUTION. + +-- WEI 3/ 4/82 +-- TBN 11/25/85 RENAMED FROM C940BAA-B.ADA. + +WITH REPORT; + USE REPORT; +PROCEDURE C94008A IS +BEGIN + TEST ("C94008A", "TERMINATION WHILE WAITING AT " & + "AN OPEN TERMINATE ALTERNATIVE"); + +BLOCK1 : + DECLARE + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + BEGIN + SELECT + WHEN TRUE => TERMINATE; + OR WHEN FALSE => ACCEPT E1; + END SELECT; + END T1; + BEGIN -- BLOCK1 + IF T1'TERMINATED THEN + FAILED ("TASK T1 TERMINATED BEFORE OUTER UNIT HAS " & + "BEEN LEFT"); + END IF; + END BLOCK1; + + RESULT; + +END C94008A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94008b.ada b/gcc/testsuite/ada/acats/tests/c9/c94008b.ada new file mode 100644 index 000000000..e72d4890e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94008b.ada @@ -0,0 +1,81 @@ +-- C94008B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TASK WAITING AT AN OPEN TERMINATE ALTERNATIVE +-- DOES N O T TERMINATE UNTIL ALL OTHER TASKS DEPENDING ON THE SAME +-- UNIT EITHER ARE TERMINATED OR ARE WAITING AT AN OPEN TERMINATE. + +-- WEI 3/ 4/82 +-- TBN 11/25/85 RENAMED FROM C940BBA-B.ADA. + +with Impdef; +WITH REPORT; + USE REPORT; +PROCEDURE C94008B IS +BEGIN + TEST ("C94008B", "TERMINATION WHILE WAITING AT AN OPEN TERMINATE"); + +BLOCK1 : + DECLARE + + TASK TYPE TT1 IS + ENTRY E1; + END TT1; + + NUMB_TT1 : CONSTANT NATURAL := 3; + DELAY_TIME : DURATION := 0.0; + ARRAY_TT1 : ARRAY (1 .. NUMB_TT1) OF TT1; + + TASK BODY TT1 IS + BEGIN + DELAY_TIME := DELAY_TIME + 1.0 * Impdef.One_Second; + DELAY DELAY_TIME; + FOR I IN 1 .. NUMB_TT1 + LOOP + IF ARRAY_TT1 (I)'TERMINATED THEN + FAILED ("TOO EARLY TERMINATION OF " & + "TASK TT1 INDEX" & INTEGER'IMAGE(I)); + END IF; + END LOOP; + + SELECT + WHEN TRUE => TERMINATE; + OR WHEN FALSE => ACCEPT E1; + END SELECT; + END TT1; + + BEGIN -- BLOCK1. + FOR I IN 1 .. NUMB_TT1 + LOOP + IF ARRAY_TT1 (I)'TERMINATED THEN + FAILED ("TERMINATION BEFORE OUTER " & + "UNIT HAS BEEN LEFT OF TASK TT1 INDEX " & + INTEGER'IMAGE(I)); + END IF; + END LOOP; + END BLOCK1; + + RESULT; + +END C94008B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94008c.ada b/gcc/testsuite/ada/acats/tests/c9/c94008c.ada new file mode 100644 index 000000000..fb2eee97f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94008c.ada @@ -0,0 +1,265 @@ +-- C94008C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT SELECT WITH TERMINATE ALTERNATIVE WORKS CORRECTLY WITH +-- NESTED TASKS. + +-- THIS TEST CONTAINS RACE CONDITIONS AND USES A GENERIC INSTANCE THAT +-- CONTAINS TASKS. + +-- JEAN-PIERRE ROSEN 24 FEBRUARY 1984 +-- JRK 4/7/86 +-- JBG 8/29/86 ELIMINATED SHARED VARIABLES; ADDED GENERIC UNIT +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94008C IS + + +-- GENERIC UNIT FOR DOING UPDATES OF SHARED VARIABLES + GENERIC + TYPE HOLDER_TYPE IS PRIVATE; + TYPE VALUE_TYPE IS PRIVATE; + INITIAL_VALUE : HOLDER_TYPE; + WITH PROCEDURE SET (HOLDER : OUT HOLDER_TYPE; + VALUE : IN HOLDER_TYPE) IS <>; + WITH PROCEDURE UPDATE (HOLDER : IN OUT HOLDER_TYPE; + VALUE : IN VALUE_TYPE) IS <>; + PACKAGE SHARED IS + PROCEDURE SET (VALUE : IN HOLDER_TYPE); + PROCEDURE UPDATE (VALUE : IN VALUE_TYPE); + FUNCTION GET RETURN HOLDER_TYPE; + END SHARED; + + PACKAGE BODY SHARED IS + TASK SHARE IS + ENTRY SET (VALUE : IN HOLDER_TYPE); + ENTRY UPDATE (VALUE : IN VALUE_TYPE); + ENTRY READ (VALUE : OUT HOLDER_TYPE); + END SHARE; + + TASK BODY SHARE IS + VARIABLE : HOLDER_TYPE; + BEGIN + LOOP + SELECT + ACCEPT SET (VALUE : IN HOLDER_TYPE) DO + SHARED.SET (VARIABLE, VALUE); + END SET; + OR + ACCEPT UPDATE (VALUE : IN VALUE_TYPE) DO + SHARED.UPDATE (VARIABLE, VALUE); + END UPDATE; + OR + ACCEPT READ (VALUE : OUT HOLDER_TYPE) DO + VALUE := VARIABLE; + END READ; + OR + TERMINATE; + END SELECT; + END LOOP; + END SHARE; + + PROCEDURE SET (VALUE : IN HOLDER_TYPE) IS + BEGIN + SHARE.SET (VALUE); + END SET; + + PROCEDURE UPDATE (VALUE : IN VALUE_TYPE) IS + BEGIN + SHARE.UPDATE (VALUE); + END UPDATE; + + FUNCTION GET RETURN HOLDER_TYPE IS + VALUE : HOLDER_TYPE; + BEGIN + SHARE.READ (VALUE); + RETURN VALUE; + END GET; + + BEGIN + SHARE.SET (INITIAL_VALUE); -- SET INITIAL VALUE + END SHARED; + + PACKAGE EVENTS IS + + TYPE EVENT_TYPE IS + RECORD + TRACE : STRING (1..4) := "...."; + LENGTH : NATURAL := 0; + END RECORD; + + PROCEDURE UPDATE (VAR : IN OUT EVENT_TYPE; VAL : CHARACTER); + PROCEDURE SET (VAR : OUT EVENT_TYPE; VAL : EVENT_TYPE); + END EVENTS; + + PACKAGE COUNTER IS + PROCEDURE UPDATE (VAR : IN OUT INTEGER; VAL : INTEGER); + PROCEDURE SET (VAR : OUT INTEGER; VAL : INTEGER); + END COUNTER; + + PACKAGE BODY COUNTER IS + PROCEDURE UPDATE (VAR : IN OUT INTEGER; VAL : INTEGER) IS + BEGIN + VAR := VAR + VAL; + END UPDATE; + + PROCEDURE SET (VAR : OUT INTEGER; VAL : INTEGER) IS + BEGIN + VAR := VAL; + END SET; + END COUNTER; + + PACKAGE BODY EVENTS IS + PROCEDURE UPDATE (VAR : IN OUT EVENT_TYPE; VAL : CHARACTER) IS + BEGIN + VAR.LENGTH := VAR.LENGTH + 1; + VAR.TRACE(VAR.LENGTH) := VAL; + END UPDATE; + + PROCEDURE SET (VAR : OUT EVENT_TYPE; VAL : EVENT_TYPE) IS + BEGIN + VAR := VAL; + END SET; + + END EVENTS; + + USE EVENTS, COUNTER; + + PACKAGE TRACE IS NEW SHARED (EVENT_TYPE, CHARACTER, ("....", 0)); + PACKAGE TERMINATE_COUNT IS NEW SHARED (INTEGER, INTEGER, 0); + + FUNCTION ENTER_TERMINATE RETURN BOOLEAN IS + BEGIN + TERMINATE_COUNT.UPDATE (1); + RETURN TRUE; + END ENTER_TERMINATE; + +BEGIN -- C94008C + + TEST ("C94008C", "CHECK CORRECT OPERATION OF SELECT WITH " & + "TERMINATE ALTERNATIVE"); + + DECLARE + + PROCEDURE EVENT (VAR : CHARACTER) RENAMES TRACE.UPDATE; + + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + + TASK T2 IS + ENTRY E2; + END T2; + + TASK BODY T2 IS + + TASK T3 IS + ENTRY E3; + END T3; + + TASK BODY T3 IS + BEGIN + SELECT + ACCEPT E3; + OR WHEN ENTER_TERMINATE => TERMINATE; + END SELECT; + EVENT ('D'); + END T3; + + BEGIN -- T2 + + SELECT + ACCEPT E2; + OR WHEN ENTER_TERMINATE => TERMINATE; + END SELECT; + + DELAY 10.0 * Impdef.One_Second; + + IF TERMINATE_COUNT.GET /= 1 THEN + DELAY 20.0 * Impdef.One_Long_Second; + END IF; + + IF TERMINATE_COUNT.GET /= 1 THEN + FAILED ("30 SECOND DELAY NOT ENOUGH - 1 "); + END IF; + + EVENT ('C'); + T1.E1; + T3.E3; + END T2; + + BEGIN -- T1; + + SELECT + ACCEPT E1; + OR WHEN ENTER_TERMINATE => TERMINATE; + END SELECT; + + EVENT ('B'); + TERMINATE_COUNT.SET (0); + T2.E2; + + SELECT + ACCEPT E1; + OR WHEN ENTER_TERMINATE => TERMINATE; + END SELECT; + + SELECT + ACCEPT E1; + OR TERMINATE; -- ONLY THIS ONE EVER CHOSEN. + END SELECT; + + FAILED ("TERMINATE NOT SELECTED IN T1"); + END T1; + + BEGIN + + DELAY 10.0 * Impdef.One_Second; -- WAIT FOR T1, T2, AND T3 TO GET TO SELECT STMTS. + + IF TERMINATE_COUNT.GET /= 3 THEN + DELAY 20.0 * Impdef.One_Long_Second; + END IF; + + IF TERMINATE_COUNT.GET /= 3 THEN + FAILED ("30 SECOND DELAY NOT ENOUGH - 2"); + END IF; + + EVENT ('A'); + T1.E1; + + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION IN MAIN BLOCK"); + END; + + IF TRACE.GET.TRACE /= "ABCD" THEN + FAILED ("INCORRECT ORDER OF EVENTS: " & TRACE.GET.TRACE); + END IF; + + RESULT; +END C94008C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94008d.ada b/gcc/testsuite/ada/acats/tests/c9/c94008d.ada new file mode 100644 index 000000000..15ca61618 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94008d.ada @@ -0,0 +1,235 @@ +-- C94008D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK CORRECT OPERATION OF SELECT WITH TERMINATE ALTERNATIVE WHEN +-- EXECUTED FROM AN INNER BLOCK WITH OUTER DEPENDING TASKS. + +-- JEAN-PIERRE ROSEN 03-MAR-84 +-- JRK 4/7/86 +-- JBG 9/4/86 ELIMINATED SHARED VARIABLES; ADDED GENERIC UNIT/SUBUNIT +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +-- GENERIC UNIT FOR DOING UPDATES OF SHARED VARIABLES +GENERIC + TYPE HOLDER_TYPE IS PRIVATE; + TYPE VALUE_TYPE IS PRIVATE; + INITIAL_VALUE : HOLDER_TYPE; + WITH PROCEDURE SET (HOLDER : OUT HOLDER_TYPE; + VALUE : IN HOLDER_TYPE) IS <>; + WITH PROCEDURE UPDATE (HOLDER : IN OUT HOLDER_TYPE; + VALUE : IN VALUE_TYPE) IS <>; +PACKAGE SHARED_C94008D IS + PROCEDURE SET (VALUE : IN HOLDER_TYPE); + PROCEDURE UPDATE (VALUE : IN VALUE_TYPE); + FUNCTION GET RETURN HOLDER_TYPE; +END SHARED_C94008D; + +PACKAGE BODY SHARED_C94008D IS + TASK SHARE IS + ENTRY SET (VALUE : IN HOLDER_TYPE); + ENTRY UPDATE (VALUE : IN VALUE_TYPE); + ENTRY READ (VALUE : OUT HOLDER_TYPE); + END SHARE; + + TASK BODY SHARE IS SEPARATE; + + PROCEDURE SET (VALUE : IN HOLDER_TYPE) IS + BEGIN + SHARE.SET (VALUE); + END SET; + + PROCEDURE UPDATE (VALUE : IN VALUE_TYPE) IS + BEGIN + SHARE.UPDATE (VALUE); + END UPDATE; + + FUNCTION GET RETURN HOLDER_TYPE IS + VALUE : HOLDER_TYPE; + BEGIN + SHARE.READ (VALUE); + RETURN VALUE; + END GET; + +BEGIN + SHARE.SET (INITIAL_VALUE); -- SET INITIAL VALUE +END SHARED_C94008D; + +PACKAGE EVENTS_C94008D IS + + TYPE EVENT_TYPE IS + RECORD + TRACE : STRING (1..4) := "...."; + LENGTH : NATURAL := 0; + END RECORD; + + PROCEDURE UPDATE (VAR : IN OUT EVENT_TYPE; VAL : CHARACTER); + PROCEDURE SET (VAR : OUT EVENT_TYPE; VAL : EVENT_TYPE); +END EVENTS_C94008D; + +PACKAGE COUNTER_C94008D IS + PROCEDURE UPDATE (VAR : IN OUT INTEGER; VAL : INTEGER); + PROCEDURE SET (VAR : OUT INTEGER; VAL : INTEGER); +END COUNTER_C94008D; + +PACKAGE BODY COUNTER_C94008D IS + PROCEDURE UPDATE (VAR : IN OUT INTEGER; VAL : INTEGER) IS + BEGIN + VAR := VAR + VAL; + END UPDATE; + + PROCEDURE SET (VAR : OUT INTEGER; VAL : INTEGER) IS + BEGIN + VAR := VAL; + END SET; +END COUNTER_C94008D; + +PACKAGE BODY EVENTS_C94008D IS + PROCEDURE UPDATE (VAR : IN OUT EVENT_TYPE; VAL : CHARACTER) IS + BEGIN + VAR.LENGTH := VAR.LENGTH + 1; + VAR.TRACE(VAR.LENGTH) := VAL; + END UPDATE; + + PROCEDURE SET (VAR : OUT EVENT_TYPE; VAL : EVENT_TYPE) IS + BEGIN + VAR := VAL; + END SET; + +END EVENTS_C94008D; + +SEPARATE (SHARED_C94008D) +TASK BODY SHARE IS + VARIABLE : HOLDER_TYPE; +BEGIN + LOOP + SELECT + ACCEPT SET (VALUE : IN HOLDER_TYPE) DO + SHARED_C94008D.SET (VARIABLE, VALUE); + END SET; + OR + ACCEPT UPDATE (VALUE : IN VALUE_TYPE) DO + SHARED_C94008D.UPDATE (VARIABLE, VALUE); + END UPDATE; + OR + ACCEPT READ (VALUE : OUT HOLDER_TYPE) DO + VALUE := VARIABLE; + END READ; + OR + TERMINATE; + END SELECT; + END LOOP; +END SHARE; + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +WITH SHARED_C94008D, COUNTER_C94008D, EVENTS_C94008D; +USE COUNTER_C94008D, EVENTS_C94008D; +PROCEDURE C94008D IS + + PACKAGE TRACE IS + NEW SHARED_C94008D (EVENT_TYPE, CHARACTER, ("....", 0)); + PACKAGE TERMINATE_COUNT IS + NEW SHARED_C94008D (INTEGER, INTEGER, 0); + + PROCEDURE EVENT (VAR : CHARACTER) RENAMES TRACE.UPDATE; + + FUNCTION ENTER_TERMINATE RETURN BOOLEAN IS + BEGIN + TERMINATE_COUNT.UPDATE (1); + RETURN TRUE; + END ENTER_TERMINATE; + +BEGIN + TEST ("C94008D", "CHECK CORRECT OPERATION OF SELECT WITH " & + "TERMINATE ALTERNATIVE FROM AN INNER BLOCK"); + + DECLARE + + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + BEGIN + DECLARE + + TASK T2 IS + ENTRY E2; + END T2; + + TASK BODY T2 IS + BEGIN + DELAY 10.0 * Impdef.One_Second; + + IF TERMINATE_COUNT.GET /= 1 THEN + DELAY 20.0 * Impdef.One_Second; + END IF; + + IF TERMINATE_COUNT.GET /= 1 THEN + FAILED ("30 SECOND DELAY NOT ENOUGH"); + END IF; + + IF T1'TERMINATED OR NOT T1'CALLABLE THEN + FAILED ("T1 PREMATURELY TERMINATED"); + END IF; + + EVENT ('A'); + + SELECT + ACCEPT E2; + OR TERMINATE; + END SELECT; + + FAILED ("TERMINATE NOT SELECTED IN T2"); + END T2; + + BEGIN + BEGIN + EVENT ('B'); + + SELECT + ACCEPT E1; + OR WHEN ENTER_TERMINATE => TERMINATE; + END SELECT; + + FAILED ("TERMINATE NOT SELECTED IN T1"); + END; + END; + END T1; + + BEGIN + EVENT ('C'); + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RECEIVED IN MAIN"); + END; + + IF TRACE.GET.TRACE(3) = '.' OR TRACE.GET.TRACE(4) /= '.' THEN + FAILED ("ALL EVENTS NOT PROCESSED CORRECTLY"); + END IF; + + COMMENT ("EXECUTION ORDER WAS " & TRACE.GET.TRACE); + + RESULT; +END C94008D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94010a.ada b/gcc/testsuite/ada/acats/tests/c9/c94010a.ada new file mode 100644 index 000000000..3fe4bd6f2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94010a.ada @@ -0,0 +1,243 @@ +-- C94010A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF A GENERIC UNIT HAS A FORMAL LIMITED PRIVATE TYPE AND +-- DECLARES AN OBJECT OF THAT TYPE (OR HAS A SUBCOMPONENT OF THAT TYPE), +-- AND IF THE UNIT IS INSTANTIATED WITH A TASK TYPE OR AN OBJECT HAVING +-- A SUBCOMPONENT OF A TASK TYPE, THEN THE USUAL RULES APPLY TO THE +-- INSTANTIATED UNIT, NAMELY: +-- A) IF THE GENERIC UNIT IS A SUBPROGRAM, CONTROL CANNOT LEAVE THE +-- SUBPROGRAM UNTIL THE TASK CREATED BY THE OBJECT DECLARATION IS +-- TERMINATED. + +-- THIS TEST CONTAINS RACE CONDITIONS AND SHARED VARIABLES. + +-- TBN 9/22/86 +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C94010A IS + + GLOBAL_INT : INTEGER := 0; + MY_EXCEPTION : EXCEPTION; + + PACKAGE P IS + TYPE LIM_PRI_TASK IS LIMITED PRIVATE; + PRIVATE + TASK TYPE LIM_PRI_TASK IS + END LIM_PRI_TASK; + END P; + + USE P; + + TASK TYPE TT IS + END TT; + + TYPE REC IS + RECORD + A : INTEGER := 1; + B : TT; + END RECORD; + + TYPE LIM_REC IS + RECORD + A : INTEGER := 1; + B : LIM_PRI_TASK; + END RECORD; + + PACKAGE BODY P IS + TASK BODY LIM_PRI_TASK IS + BEGIN + DELAY 30.0 * Impdef.One_Second; + GLOBAL_INT := IDENT_INT (2); + END LIM_PRI_TASK; + END P; + + TASK BODY TT IS + BEGIN + DELAY 30.0 * Impdef.One_Second; + GLOBAL_INT := IDENT_INT (1); + END TT; + + GENERIC + TYPE T IS LIMITED PRIVATE; + PROCEDURE PROC (A : INTEGER); + + PROCEDURE PROC (A : INTEGER) IS + OBJ_T : T; + BEGIN + IF A = IDENT_INT (1) THEN + RAISE MY_EXCEPTION; + END IF; + END PROC; + + GENERIC + TYPE T IS LIMITED PRIVATE; + FUNCTION FUNC (A : INTEGER) RETURN INTEGER; + + FUNCTION FUNC (A : INTEGER) RETURN INTEGER IS + OBJ_T : T; + BEGIN + IF A = IDENT_INT (1) THEN + RAISE MY_EXCEPTION; + END IF; + RETURN 1; + END FUNC; + + +BEGIN + TEST ("C94010A", "CHECK TERMINATION RULES FOR INSTANTIATIONS OF " & + "GENERIC SUBPROGRAM UNITS WHICH CREATE TASKS"); + + ------------------------------------------------------------------- + DECLARE + PROCEDURE PROC1 IS NEW PROC (TT); + BEGIN + PROC1 (0); + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 1"); + DELAY 35.0; + END IF; + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + PROCEDURE PROC2 IS NEW PROC (REC); + BEGIN + PROC2 (1); + FAILED ("EXCEPTION WAS NOT RAISED - 2"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 2"); + DELAY 35.0 * Impdef.One_Second; + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + PROCEDURE PROC3 IS NEW PROC (LIM_PRI_TASK); + BEGIN + PROC3 (1); + FAILED ("EXCEPTION WAS NOT RAISED - 3"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 3"); + DELAY 35.0 * Impdef.One_Second; + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + PROCEDURE PROC4 IS NEW PROC (LIM_REC); + BEGIN + PROC4 (0); + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 4"); + DELAY 35.0 * Impdef.One_Second; + END IF; + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + A : INTEGER; + FUNCTION FUNC1 IS NEW FUNC (TT); + BEGIN + A := FUNC1 (1); + FAILED ("EXCEPTION NOT RAISED - 5"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 5"); + DELAY 35.0 * Impdef.One_Second; + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + A : INTEGER; + FUNCTION FUNC2 IS NEW FUNC (REC); + BEGIN + A := FUNC2 (0); + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 6"); + DELAY 35.0 * Impdef.One_Second; + END IF; + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + A : INTEGER; + FUNCTION FUNC3 IS NEW FUNC (LIM_PRI_TASK); + BEGIN + A := FUNC3 (0); + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 7"); + DELAY 35.0 * Impdef.One_Second; + END IF; + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + A : INTEGER; + FUNCTION FUNC4 IS NEW FUNC (LIM_REC); + BEGIN + A := FUNC4 (1); + FAILED ("EXCEPTION NOT RAISED - 8"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 8"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 8"); + END; + + ------------------------------------------------------------------- + + RESULT; +END C94010A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94011a.ada b/gcc/testsuite/ada/acats/tests/c9/c94011a.ada new file mode 100644 index 000000000..c504f0692 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94011a.ada @@ -0,0 +1,268 @@ +-- C94011A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF A FORMAL ACCESS TYPE OF A GENERIC UNIT DESIGNATES A +-- FORMAL LIMITED PRIVATE TYPE, THEN WHEN THE UNIT IS INSTANTIATED WITH +-- A TASK TYPE OR A TYPE HAVING A SUBCOMPONENT OF A TASK TYPE, THE +-- MASTER FOR ANY TASKS ALLOCATED WITHIN THE INSTANTIATED UNIT IS +-- DETERMINED BY THE ACTUAL PARAMETER. + +-- TBN 9/22/86 + +WITH REPORT; USE REPORT; +PROCEDURE C94011A IS + + GLOBAL_INT : INTEGER := 0; + MY_EXCEPTION : EXCEPTION; + + PACKAGE P IS + TYPE LIM_PRI_TASK IS LIMITED PRIVATE; + PROCEDURE E (T : LIM_PRI_TASK); + PRIVATE + TASK TYPE LIM_PRI_TASK IS + ENTRY E; + END LIM_PRI_TASK; + END P; + + USE P; + + TASK TYPE TT IS + ENTRY E; + END TT; + + TYPE REC IS + RECORD + A : INTEGER := 1; + B : TT; + END RECORD; + + TYPE LIM_REC IS + RECORD + A : INTEGER := 1; + B : LIM_PRI_TASK; + END RECORD; + + PACKAGE BODY P IS + TASK BODY LIM_PRI_TASK IS + BEGIN + ACCEPT E; + GLOBAL_INT := IDENT_INT (2); + END LIM_PRI_TASK; + + PROCEDURE E (T : LIM_PRI_TASK) IS + BEGIN + T.E; + END E; + END P; + + TASK BODY TT IS + BEGIN + ACCEPT E; + GLOBAL_INT := IDENT_INT (1); + END TT; + + GENERIC + TYPE T IS LIMITED PRIVATE; + TYPE ACC_T IS ACCESS T; + PROCEDURE PROC (A : OUT ACC_T); + + PROCEDURE PROC (A : OUT ACC_T) IS + BEGIN + A := NEW T; + END PROC; + + GENERIC + TYPE T IS LIMITED PRIVATE; + TYPE ACC_T IS ACCESS T; + FUNCTION FUNC RETURN ACC_T; + + FUNCTION FUNC RETURN ACC_T IS + BEGIN + RETURN NEW T; + END FUNC; + + GENERIC + TYPE T IS LIMITED PRIVATE; + TYPE ACC_T IS ACCESS T; + PACKAGE PAC IS + PTR_T : ACC_T := NEW T; + END PAC; + +BEGIN + TEST ("C94011A", "CHECK THAT IF A FORMAL ACCESS TYPE OF A " & + "GENERIC UNIT DESIGNATES A FORMAL LIMITED " & + "PRIVATE TYPE, THEN WHEN THE UNIT IS " & + "INSTANTIATED, THE MASTER FOR ANY TASKS " & + "ALLOCATED WITHIN THE INSTANTIATED UNIT IS " & + "DETERMINED BY THE ACTUAL PARAMETER"); + + ------------------------------------------------------------------- + DECLARE + TYPE ACC_TT IS ACCESS TT; + ACC1 : ACC_TT; + PROCEDURE PROC1 IS NEW PROC (TT, ACC_TT); + BEGIN + PROC1 (ACC1); + ACC1.E; + EXCEPTION + WHEN OTHERS => + FAILED ("TASK DEPENDENT ON WRONG MASTER - 1"); + END; + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 1"); + END IF; + + ------------------------------------------------------------------- + BEGIN + GLOBAL_INT := IDENT_INT (0); + DECLARE + TYPE ACC_REC IS ACCESS REC; + A : ACC_REC; + FUNCTION FUNC1 IS NEW FUNC (REC, ACC_REC); + BEGIN + A := FUNC1; + A.B.E; + RAISE MY_EXCEPTION; + EXCEPTION + WHEN MY_EXCEPTION => + RAISE MY_EXCEPTION; + WHEN OTHERS => + FAILED ("TASK DEPENDENT ON WRONG MASTER - 2"); + END; + FAILED ("MY_EXCEPTION NOT RAISED - 2"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 2"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + BEGIN + DECLARE + TYPE ACC_LIM_TT IS ACCESS LIM_PRI_TASK; + BEGIN + DECLARE + A : ACC_LIM_TT; + FUNCTION FUNC2 IS NEW FUNC (LIM_PRI_TASK, + ACC_LIM_TT); + BEGIN + A := FUNC2; + E (A.ALL); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("TASK DEPENDENT ON WRONG MASTER - 3"); + END; + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 3"); + END IF; + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + BEGIN + DECLARE + TYPE ACC_LIM_REC IS ACCESS LIM_REC; + BEGIN + DECLARE + ACC2 : ACC_LIM_REC; + PROCEDURE PROC2 IS NEW PROC (LIM_REC, ACC_LIM_REC); + BEGIN + PROC2 (ACC2); + E (ACC2.B); + END; + RAISE MY_EXCEPTION; + EXCEPTION + WHEN MY_EXCEPTION => + RAISE MY_EXCEPTION; + WHEN OTHERS => + FAILED ("TASK DEPENDENT ON WRONG MASTER - 4"); + END; + FAILED ("MY_EXCEPTION NOT RAISED - 4"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 4"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END; + + ------------------------------------------------------------------- + BEGIN + GLOBAL_INT := IDENT_INT (0); + + DECLARE + TYPE ACC_TT IS ACCESS TT; + PACKAGE PAC1 IS NEW PAC (TT, ACC_TT); + USE PAC1; + BEGIN + PTR_T.E; + RAISE MY_EXCEPTION; + EXCEPTION + WHEN MY_EXCEPTION => + RAISE MY_EXCEPTION; + WHEN OTHERS => + FAILED ("TASK DEPENDENT ON WRONG MASTER - 5"); + END; + FAILED ("MY_EXCEPTION NOT RAISED - 5"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 5"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + TYPE ACC_LIM_REC IS ACCESS LIM_REC; + BEGIN + DECLARE + PACKAGE PAC2 IS NEW PAC (LIM_REC, ACC_LIM_REC); + USE PAC2; + BEGIN + E (PTR_T.B); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("TASK DEPENDENT ON WRONG MASTER - 6"); + END; + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 6"); + END IF; + + ------------------------------------------------------------------- + + RESULT; +END C94011A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c94020a.ada b/gcc/testsuite/ada/acats/tests/c9/c94020a.ada new file mode 100644 index 000000000..4a5037ecd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c94020a.ada @@ -0,0 +1,111 @@ +-- C94020A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE CONDITIONS FOR TERMINATION ARE RECOGNIZED WHEN THE +-- LAST MISSING TASK TERMINATES DUE TO AN ABORT + +-- JEAN-PIERRE ROSEN 08-MAR-1984 +-- JBG 6/1/84 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE C94020A IS + + TASK TYPE T2 IS + END T2; + + TASK TYPE T3 IS + ENTRY E; + END T3; + + TASK BODY T2 IS + BEGIN + COMMENT("T2"); + END; + + TASK BODY T3 IS + BEGIN + COMMENT("T3"); + SELECT + ACCEPT E; + OR TERMINATE; + END SELECT; + FAILED("T3 EXITED SELECT OR TERMINATE"); + END; + +BEGIN + + TEST ("C94020A", "TEST OF TASK DEPENDENCES, TERMINATE, ABORT"); + + DECLARE + TASK TYPE T1 IS + END T1; + + V1 : T1; + TYPE A_T1 IS ACCESS T1; + + TASK BODY T1 IS + BEGIN + ABORT T1; + DELAY 0.0; --SYNCHRONIZATION POINT + FAILED("T1 NOT ABORTED"); + END; + + BEGIN + DECLARE + V2 : T2; + A1 : A_T1; + BEGIN + DECLARE + V3 : T3; + TASK T4 IS + END T4; + TASK BODY T4 IS + TASK T41 IS + END T41; + TASK BODY T41 IS + BEGIN + COMMENT("T41"); + ABORT T4; + DELAY 0.0; --SYNCHRONIZATION POINT + FAILED("T41 NOT ABORTED"); + END; + BEGIN --T4 + COMMENT("T4"); + END; + BEGIN + COMMENT("BLOC 3"); + END; + COMMENT("BLOC 2"); + A1 := NEW T1; + END; + COMMENT("BLOC 1"); + EXCEPTION + WHEN OTHERS => FAILED("SOME EXCEPTION RAISED"); + END; + + RESULT; + +END C94020A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c940a03.a b/gcc/testsuite/ada/acats/tests/c9/c940a03.a new file mode 100644 index 000000000..22876d26b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c940a03.a @@ -0,0 +1,350 @@ +-- C940A03.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a protected object provides coordinated access to +-- shared data. Check that it can implement a semaphore-like construct +-- controlling access to shared data through procedure parameters to +-- allow a specific maximum number of tasks to run and exclude all +-- others. +-- +-- TEST DESCRIPTION: +-- Declare a resource descriptor tagged type. Extend the type and +-- use the extended type in a protected data structure. +-- Implement a counting semaphore type that can be initialized to a +-- specific number of available resources. Declare an entry for +-- requesting a specific resource and an procedure for releasing the +-- same resource it. Declare an object of this (protected) type, +-- initialized to two resources. Declare and start three tasks each +-- of which asks for a resource. Verify that only two resources are +-- granted and that the last task in is queued. +-- +-- This test models a multi-user operating system that allows a limited +-- number of logins. Users requesting login are modeled by tasks. +-- +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- F940A00 +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 13 Nov 95 SAIC Fixed bugs for ACVC 2.0.1 +-- +--! + +package C940A03_0 is + --Resource_Pkg + + -- General type declarations that will be extended to model available + -- logins + + type Resource_ID_Type is range 0..10; + type Resource_Type is tagged record + Id : Resource_ID_Type := 0; + end record; + +end C940A03_0; + --Resource_Pkg + +--======================================-- +-- no body for C940A3_0 +--======================================-- + +with F940A00; -- Interlock_Foundation +with C940A03_0; -- Resource_Pkg; + +package C940A03_1 is + -- Semaphores + + -- Models a counting semaphore that will allow up to a specific + -- number of logins + -- Users (tasks) request a login slot by calling the Request_Login + -- entry and logout by calling the Release_Login procedure + + Max_Logins : constant Integer := 2; + + + type Key_Type is range 0..100; + -- When a user requests a login, an + -- identifying key will be returned + Init_Key : constant Key_Type := 0; + + type Login_Record_Type is new C940A03_0.Resource_Type with record + Key : Key_Type := Init_Key; + end record; + + + protected type Login_Semaphore_Type (Resources_Available : Integer :=1) is + + entry Request_Login (Resource_Key : in out Login_Record_Type); + procedure Release_Login; + function Available return Integer; -- how many logins are available? + private + Logins_Avail : Integer := Resources_Available; + Next_Key : Key_Type := Init_Key; + + end Login_Semaphore_Type; + + Login_Semaphore : Login_Semaphore_Type (Max_Logins); + + --====== machinery for the test, not the model =====-- + TC_Control_Message : F940A00.Interlock_Type; + function TC_Key_Val (Login_Rec : Login_Record_Type) return Integer; + + +end C940A03_1; + -- Semaphores; + +--=========================================================-- + +package body C940A03_1 is + -- Semaphores is + + protected body Login_Semaphore_Type is + + entry Request_Login (Resource_Key : in out Login_Record_Type) + when Logins_Avail > 0 is + begin + Next_Key := Next_Key + 1; -- login process returns a key + Resource_Key.Key := Next_Key; -- to the requesting user + Logins_Avail := Logins_Avail - 1; + end Request_Login; + + procedure Release_Login is + begin + Logins_Avail := Logins_Avail + 1; + end Release_Login; + + function Available return Integer is + begin + return Logins_Avail; + end Available; + + end Login_Semaphore_Type; + + function TC_Key_Val (Login_Rec : Login_Record_Type) return Integer is + begin + return Integer (Login_Rec.Key); + end TC_Key_Val; + +end C940A03_1; + -- Semaphores; + +--=========================================================-- + +with C940A03_0; -- Resource_Pkg, +with C940A03_1; -- Semaphores; + +package C940A03_2 is + -- Task_Pkg + + package Semaphores renames C940A03_1; + + task type User_Task_Type is + + entry Login (user_id : C940A03_0.Resource_Id_Type); + -- instructs the task to ask for a login + entry Logout; -- instructs the task to release the login + --=======================-- + -- this entry is used to get information to verify test operation + entry Get_Status (User_Record : out Semaphores.Login_Record_Type); + + end User_Task_Type; + +end C940A03_2; + -- Task_Pkg + +--=========================================================-- + +with Report; +with C940A03_0; -- Resource_Pkg, +with C940A03_1; -- Semaphores, +with F940A00; -- Interlock_Foundation; + +package body C940A03_2 is + -- Task_Pkg + + -- This task models a user requesting a login from the system + -- For control of this test, we can ask the task to login, logout, or + -- give us the current user record (containing login information) + + task body User_Task_Type is + Rec : Semaphores.Login_Record_Type; + begin + loop + select + accept Login (user_id : C940A03_0.Resource_Id_Type) do + Rec.Id := user_id; + end Login; + + Semaphores.Login_Semaphore.Request_Login (Rec); + -- request a resource; if resource is not available, + -- task will be queued to wait + + --== following is test control machinery ==-- + F940A00.Counter.Increment; + Semaphores.TC_Control_Message.Post; + -- after resource is obtained, post message + + or + accept Logout do + Semaphores.Login_Semaphore.Release_Login; + -- release the resource + --== test control machinery ==-- + F940A00.Counter.Decrement; + end Logout; + exit; + + or + accept Get_Status (User_Record : out Semaphores.Login_Record_Type) do + User_Record := Rec; + end Get_Status; + + end select; + end loop; + + exception + when others => Report.Failed ("Exception raised in model user task"); + end User_Task_Type; + +end C940A03_2; + -- Task_Pkg + +--=========================================================-- + +with Report; +with ImpDef; +with C940A03_1; -- Semaphores, +with C940A03_2; -- Task_Pkg, +with F940A00; -- Interlock_Foundation; + +procedure C940A03 is + + package Semaphores renames C940A03_1; + package Users renames C940A03_2; + + Task1, Task2, Task3 : Users.User_Task_Type; + User_Rec : Semaphores.Login_Record_Type; + +begin -- Tasks start here + + Report.Test ("C940A03", "Check that a protected object can coordinate " & + "shared data access using procedure parameters"); + + if F940A00.Counter.Number /=0 then + Report.Failed ("Wrong initial conditions"); + end if; + + Task1.Login (1); -- request resource; request should be granted + Semaphores.TC_Control_Message.Consume; + -- ensure that task obtains resource by + -- waiting for task to post message + + -- Task 1 waiting for call to Logout + -- Others still available + Task1.Get_Status (User_Rec); + if (F940A00.Counter.Number /= 1) + or (Semaphores.Login_Semaphore.Available /=1) + or (Semaphores.TC_Key_Val (User_Rec) /= 1) then + Report.Failed ("Resource not assigned to task 1"); + end if; + + Task2.Login (2); -- Request for resource should be granted + Semaphores.TC_Control_Message.Consume; + -- ensure that task obtains resource by + -- waiting for task to post message + + Task2.Get_Status (User_Rec); + if (F940A00.Counter.Number /= 2) + or (Semaphores.Login_Semaphore.Available /=0) + or (Semaphores.TC_Key_Val (User_Rec) /= 2) then + Report.Failed ("Resource not assigned to task 2"); + end if; + + + Task3.Login (3); -- request for resource should be denied + -- and task queued + + + -- Tasks 1 and 2 holds resources + -- and are waiting for a call to Logout + -- Task 3 is queued + + if (F940A00.Counter.Number /= 2) + or (Semaphores.Login_Semaphore.Available /=0) then + Report.Failed ("Resource incorrectly assigned to task 3"); + end if; + + Task1.Logout; -- released resource should be given to + -- queued task + Semaphores.TC_Control_Message.Consume; + -- wait for confirming message from task + + -- Task 1 holds no resources + -- and is terminated (or will soon) + -- Tasks 2 and 3 hold resources + -- and are waiting for a call to Logout + + Task3.Get_Status (User_Rec); + if (F940A00.Counter.Number /= 2) + or (Semaphores.Login_Semaphore.Available /=0) + or (Semaphores.TC_Key_Val (User_Rec) /= 3) then + Report.Failed ("Resource not properly released/assigned to task 3"); + end if; + + Task2.Logout; -- no outstanding request for released + -- resource + -- Tasks 1 and 2 hold no resources + -- Task 3 holds a resource + -- and is waiting for a call to Logout + + if (F940A00.Counter.Number /= 1) + or (Semaphores.Login_Semaphore.Available /=1) then + Report.Failed ("Resource not properly released from task 2"); + end if; + + Task3.Logout; + + -- all resources have been returned + -- all tasks have terminated or will soon + + if (F940A00.Counter.Number /=0) + or (Semaphores.Login_Semaphore.Available /=2) then + Report.Failed ("Resource not properly released from task 3"); + end if; + + -- Ensure all tasks have terminated before calling Result + while not (Task1'terminated and + Task2'terminated and + Task3'terminated) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + +end C940A03; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95008a.ada b/gcc/testsuite/ada/acats/tests/c9/c95008a.ada new file mode 100644 index 000000000..4343e651b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95008a.ada @@ -0,0 +1,426 @@ +-- C95008A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE EXCEPTION CONSTRAINT_ERROR IS RAISED FOR AN +-- OUT-OF-RANGE INDEX VALUE WHEN REFERENCING AN ENTRY FAMILY, +-- EITHER IN AN ACCEPT_STATEMENT OR IN AN ENTRY_CALL. + +-- SUBTESTS ARE: +-- (A) INTEGER TYPE, STATIC LOWER BOUND, NO PARAMETERS. +-- (B) CHARACTER TYPE, DYNAMIC UPPER BOUND, NO PARAMETERS. +-- (C) BOOLEAN TYPE, STATIC NULL RANGE, NO PARAMETERS. +-- (D) USER-DEFINED ENUMERATED TYPE, DYNAMIC LOWER BOUND, ONE +-- PARAMETER. +-- (E) DERIVED INTEGER TYPE, DYNAMIC NULL RANGE, ONE PARAMETER. +-- (F) DERIVED USER-DEFINED ENUMERATED TYPE, STATIC UPPER BOUND, +-- ONE PARAMETER. + +-- JRK 11/4/81 +-- JBG 11/11/84 +-- SAIC 11/14/95 fixed test for 2.0.1 + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C95008A IS + + C_E_NOT_RAISED : BOOLEAN; + WRONG_EXC_RAISED : BOOLEAN; + +BEGIN + TEST ("C95008A", "OUT-OF-RANGE ENTRY FAMILY INDICES IN " & + "ACCEPT_STATEMENTS AND ENTRY_CALLS"); + + -------------------------------------------------- + + C_E_NOT_RAISED := FALSE; + WRONG_EXC_RAISED := FALSE; + + DECLARE -- (A) + + TASK T IS + ENTRY E (1..10); + ENTRY CONTINUE; + END T; + + TASK BODY T IS + BEGIN + ACCEPT CONTINUE; + SELECT + ACCEPT E (0); + OR + DELAY 1.0 * Impdef.One_Second; + END SELECT; + C_E_NOT_RAISED := TRUE; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + WRONG_EXC_RAISED := TRUE; + END T; + + BEGIN -- (A) + + SELECT + T.E (0); + OR + DELAY 15.0 * Impdef.One_Second; + END SELECT; + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ENTRY_CALL - (A)"); + T.CONTINUE; + + EXCEPTION -- (A) + + WHEN CONSTRAINT_ERROR => + T.CONTINUE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN " & + "ENTRY_CALL - (A)"); + T.CONTINUE; + + END; -- (A) + + IF C_E_NOT_RAISED THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ACCEPT_STATEMENT - (A)"); + END IF; + + IF WRONG_EXC_RAISED THEN + FAILED ("WRONG EXCEPTION RAISED IN " & + "ACCEPT_STATEMENT - (A)"); + END IF; + + -------------------------------------------------- + + C_E_NOT_RAISED := FALSE; + WRONG_EXC_RAISED := FALSE; + + DECLARE -- (B) + + TASK T IS + ENTRY E (CHARACTER RANGE 'A'..'Y'); + ENTRY CONTINUE; + END T; + + TASK BODY T IS + BEGIN + ACCEPT CONTINUE; + SELECT + ACCEPT E (IDENT_CHAR('Z')); + OR + DELAY 1.0 * Impdef.One_Second; + END SELECT; + C_E_NOT_RAISED := TRUE; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + WRONG_EXC_RAISED := TRUE; + END T; + + BEGIN -- (B) + + SELECT + T.E (IDENT_CHAR('Z')); + OR + DELAY 15.0 * Impdef.One_Second; + END SELECT; + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ENTRY_CALL - (B)"); + T.CONTINUE; + + EXCEPTION -- (B) + + WHEN CONSTRAINT_ERROR => + T.CONTINUE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN " & + "ENTRY_CALL - (B)"); + T.CONTINUE; + + END; -- (B) + + IF C_E_NOT_RAISED THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ACCEPT_STATEMENT - (B)"); + END IF; + + IF WRONG_EXC_RAISED THEN + FAILED ("WRONG EXCEPTION RAISED IN " & + "ACCEPT_STATEMENT - (B)"); + END IF; + + -------------------------------------------------- + + C_E_NOT_RAISED := FALSE; + WRONG_EXC_RAISED := FALSE; + + DECLARE -- (C) + + TASK T IS + ENTRY E (TRUE..FALSE); + ENTRY CONTINUE; + END T; + + TASK BODY T IS + BEGIN + ACCEPT CONTINUE; + SELECT + ACCEPT E (FALSE); + OR + DELAY 1.0 * Impdef.One_Second; + END SELECT; + C_E_NOT_RAISED := TRUE; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + WRONG_EXC_RAISED := TRUE; + END T; + + BEGIN -- (C) + + SELECT + T.E (TRUE); + OR + DELAY 15.0 * Impdef.One_Second; + END SELECT; + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ENTRY_CALL - (C)"); + T.CONTINUE; + + EXCEPTION -- (C) + + WHEN CONSTRAINT_ERROR => + T.CONTINUE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN " & + "ENTRY_CALL - (C)"); + T.CONTINUE; + + END; -- (C) + + IF C_E_NOT_RAISED THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ACCEPT_STATEMENT - (C)"); + END IF; + + IF WRONG_EXC_RAISED THEN + FAILED ("WRONG EXCEPTION RAISED IN " & + "ACCEPT_STATEMENT - (C)"); + END IF; + + -------------------------------------------------- + + C_E_NOT_RAISED := FALSE; + WRONG_EXC_RAISED := FALSE; + + DECLARE -- (D) + + TYPE ET IS (E0, E1, E2); + DLB : ET := ET'VAL (IDENT_INT(1)); -- E1. + + TASK T IS + ENTRY E (ET RANGE DLB..E2) (I : INTEGER); + ENTRY CONTINUE; + END T; + + TASK BODY T IS + BEGIN + ACCEPT CONTINUE; + SELECT + ACCEPT E (E0) (I : INTEGER); + OR + DELAY 1.0 * Impdef.One_Second; + END SELECT; + C_E_NOT_RAISED := TRUE; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + WRONG_EXC_RAISED := TRUE; + END T; + + BEGIN -- (D) + + SELECT + T.E (E0) (0); + OR + DELAY 15.0 * Impdef.One_Second; + END SELECT; + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ENTRY_CALL - (D)"); + T.CONTINUE; + + EXCEPTION -- (D) + + WHEN CONSTRAINT_ERROR => + T.CONTINUE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN " & + "ENTRY_CALL - (D)"); + T.CONTINUE; + + END; -- (D) + + IF C_E_NOT_RAISED THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ACCEPT_STATEMENT - (D)"); + END IF; + + IF WRONG_EXC_RAISED THEN + FAILED ("WRONG EXCEPTION RAISED IN " & + "ACCEPT_STATEMENT - (D)"); + END IF; + + -------------------------------------------------- + + C_E_NOT_RAISED := FALSE; + WRONG_EXC_RAISED := FALSE; + + DECLARE -- (E) + + TYPE D_I IS NEW INTEGER; + SUBTYPE DI IS D_I RANGE 3 .. D_I(IDENT_INT(2)); + + TASK T IS + ENTRY E (DI) (I : INTEGER); + ENTRY CONTINUE; + END T; + + TASK BODY T IS + BEGIN + ACCEPT CONTINUE; + SELECT + ACCEPT E (D_I(3)) (I : INTEGER); + OR + DELAY 1.0 * Impdef.One_Second; + END SELECT; + C_E_NOT_RAISED := TRUE; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + WRONG_EXC_RAISED := TRUE; + END T; + + BEGIN -- (E) + + SELECT + T.E (D_I(2)) (0); + OR + DELAY 15.0 * Impdef.One_Second; + END SELECT; + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ENTRY_CALL - (E)"); + T.CONTINUE; + + EXCEPTION -- (E) + + WHEN CONSTRAINT_ERROR => + T.CONTINUE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN " & + "ENTRY_CALL - (E)"); + T.CONTINUE; + + END; -- (E) + + IF C_E_NOT_RAISED THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ACCEPT_STATEMENT - (E)"); + END IF; + + IF WRONG_EXC_RAISED THEN + FAILED ("WRONG EXCEPTION RAISED IN " & + "ACCEPT_STATEMENT - (E)"); + END IF; + + -------------------------------------------------- + + C_E_NOT_RAISED := FALSE; + WRONG_EXC_RAISED := FALSE; + + DECLARE -- (F) + + TYPE ET IS (E0, E1, E2); + TYPE D_ET IS NEW ET; + + TASK T IS + ENTRY E (D_ET RANGE E0..E1) (I : INTEGER); + ENTRY CONTINUE; + END T; + + TASK BODY T IS + BEGIN + ACCEPT CONTINUE; + SELECT + ACCEPT E (D_ET'(E2)) (I : INTEGER); + OR + DELAY 1.0 * Impdef.One_Second; + END SELECT; + C_E_NOT_RAISED := TRUE; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + WRONG_EXC_RAISED := TRUE; + END T; + + BEGIN -- (F) + + SELECT + T.E (D_ET'(E2)) (0); + OR + DELAY 15.0 * Impdef.One_Second; + END SELECT; + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ENTRY_CALL - (F)"); + T.CONTINUE; + + EXCEPTION -- (F) + + WHEN CONSTRAINT_ERROR => + T.CONTINUE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN " & + "ENTRY_CALL - (F)"); + T.CONTINUE; + + END; -- (F) + + IF C_E_NOT_RAISED THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ACCEPT_STATEMENT - (F)"); + END IF; + + IF WRONG_EXC_RAISED THEN + FAILED ("WRONG EXCEPTION RAISED IN " & + "ACCEPT_STATEMENT - (F)"); + END IF; + + -------------------------------------------------- + + RESULT; +END C95008A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95009a.ada b/gcc/testsuite/ada/acats/tests/c9/c95009a.ada new file mode 100644 index 000000000..30830e96c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95009a.ada @@ -0,0 +1,121 @@ +-- C95009A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TASK OBJECT CAN CALL ENTRIES OF OTHER TASKS. + +-- THIS TEST CONTAINS SHARED VARIABLES. + +-- JRK 11/5/81 +-- JRK 8/3/84 + +WITH REPORT; USE REPORT; +PROCEDURE C95009A IS + + V1 : INTEGER := 0; + V2 : INTEGER := 0; + + PI : INTEGER := 0; + PO : INTEGER := 0; + +BEGIN + TEST ("C95009A", "CHECK THAT A TASK OBJECT CAN CALL ENTRIES " & + "OF OTHER TASKS"); + + DECLARE + + SUBTYPE INT IS INTEGER RANGE 1..5; + + TASK T1 IS + ENTRY E1N; + ENTRY EF1P (INT) (I : OUT INTEGER); + END T1; + + TASK TYPE T2T IS + ENTRY E2P (I : INTEGER); + ENTRY EF2N (INT); + END T2T; + + TYPE AT2T IS ACCESS T2T; + AT2 : AT2T; + + TASK BODY T1 IS + BEGIN + V1 := 1; + ACCEPT E1N; + V1 := 2; + AT2.E2P (1); + V1 := 3; + ACCEPT EF1P (2) (I : OUT INTEGER) DO + I := 2; + END EF1P; + V1 := 4; + AT2.EF2N (IDENT_INT(3)); + V1 := 5; + END T1; + + TASK BODY T2T IS + BEGIN + V2 := 1; + T1.E1N; + V2 := 2; + ACCEPT E2P (I : INTEGER) DO + PI := I; + END E2P; + V2 := 3; + T1.EF1P (2) (PO); + V2 := 4; + ACCEPT EF2N (1+IDENT_INT(2)); + V2 := 5; + END T2T; + + PACKAGE DUMMY IS + END DUMMY; + + PACKAGE BODY DUMMY IS + BEGIN + AT2 := NEW T2T; + END DUMMY; + + BEGIN + NULL; + END; + + IF V1 /= 5 THEN + FAILED ("TASK T1 ONLY REACHED V1 = " & INTEGER'IMAGE(V1)); + END IF; + + IF V2 /= 5 THEN + FAILED ("TASK AT2 ONLY REACHED V2 = " & INTEGER'IMAGE(V2)); + END IF; + + IF PI /= 1 THEN + FAILED ("ENTRY IN PARAMETER NOT PASSED CORRECTLY"); + END IF; + + IF PO /= 2 THEN + FAILED ("ENTRY OUT PARAMETER NOT PASSED CORRECTLY"); + END IF; + + RESULT; +END C95009A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95010a.ada b/gcc/testsuite/ada/acats/tests/c9/c95010a.ada new file mode 100644 index 000000000..362956058 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95010a.ada @@ -0,0 +1,82 @@ +-- C95010A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TASK MAY CONTAIN MORE THAN ONE ACCEPT_STATEMENT +-- FOR AN ENTRY. + +-- THIS TEST CONTAINS SHARED VARIABLES. + +-- JRK 11/5/81 +-- JWC 6/28/85 RENAMED TO -AB + +WITH REPORT; USE REPORT; +PROCEDURE C95010A IS + + V : INTEGER := 0; + +BEGIN + TEST ("C95010A", "CHECK THAT A TASK MAY CONTAIN MORE THAN " & + "ONE ACCEPT_STATEMENT FOR AN ENTRY"); + + DECLARE + + SUBTYPE INT IS INTEGER RANGE 1..5; + + TASK T IS + ENTRY E; + ENTRY EF (INT) (I : INTEGER); + END T; + + TASK BODY T IS + BEGIN + V := 1; + ACCEPT E; + V := 2; + ACCEPT E; + V := 3; + ACCEPT EF (2) (I : INTEGER) DO + V := I; + END EF; + V := 5; + ACCEPT EF (2) (I : INTEGER) DO + V := I; + END EF; + V := 7; + END T; + + BEGIN + + T.E; + T.E; + T.EF (2) (4); + T.EF (2) (6); + + END; + + IF V /= 7 THEN + FAILED ("WRONG CONTROL FLOW VALUE"); + END IF; + + RESULT; +END C95010A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95011a.ada b/gcc/testsuite/ada/acats/tests/c9/c95011a.ada new file mode 100644 index 000000000..1e91a847c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95011a.ada @@ -0,0 +1,67 @@ +-- C95011A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TASK NEED NOT CONTAIN ANY ACCEPT_STATEMENTS FOR AN +-- ENTRY. + +-- THIS TEST CONTAINS SHARED VARIABLES. + +-- JRK 11/5/81 +-- JWC 6/28/85 RENAMED TO -AB + +WITH REPORT; USE REPORT; +PROCEDURE C95011A IS + + V : INTEGER := 0; + +BEGIN + TEST ("C95011A", "CHECK THAT A TASK NEED NOT CONTAIN ANY " & + "ACCEPT_STATEMENTS FOR AN ENTRY"); + + DECLARE + + SUBTYPE INT IS INTEGER RANGE 1..5; + + TASK T IS + ENTRY E; + ENTRY EF (INT) (I : INTEGER); + END T; + + TASK BODY T IS + BEGIN + V := 1; + END T; + + BEGIN + + NULL; + + END; + + IF V /= 1 THEN + FAILED ("WRONG CONTROL FLOW VALUE"); + END IF; + + RESULT; +END C95011A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95012a.ada b/gcc/testsuite/ada/acats/tests/c9/c95012a.ada new file mode 100644 index 000000000..2f7efaacb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95012a.ada @@ -0,0 +1,106 @@ +-- C95012A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A CALL TO AN ENTRY OF A TASK THAT HAS NOT BEEN ACTIVATED +-- DOES NOT RAISE EXCEPTIONS. + +-- THIS TEST CONTAINS RACE CONDITIONS. + +-- JRK 11/6/81 +-- SPS 11/21/82 +-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C95012A IS + + I : INTEGER := 0; + + +BEGIN + TEST ("C95012A", "CHECK THAT A CALL TO AN ENTRY OF A TASK " & + "THAT HAS NOT BEEN ACTIVATED DOES NOT " & + "RAISE EXCEPTIONS"); + + DECLARE + + TASK T1 IS + ENTRY E1 (I : OUT INTEGER); + END T1; + + TASK TYPE T2T IS + ENTRY E2 (I : OUT INTEGER); + END T2T; + + TYPE AT2T IS ACCESS T2T; + AT2 : AT2T; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (I : OUT INTEGER) DO + I := IDENT_INT (1); + END E1; + END T1; + + TASK BODY T2T IS + J : INTEGER := 0; + BEGIN + BEGIN + T1.E1 (J); + EXCEPTION + WHEN OTHERS => + J := -1; + END; + ACCEPT E2 (I : OUT INTEGER) DO + I := J; + END E2; + END T2T; + + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + AT2 := NEW T2T; + DELAY 60.0 * Impdef.One_Second; + END PKG; + + BEGIN + + AT2.ALL.E2 (I); + + IF I = -1 THEN + FAILED ("EXCEPTION RAISED"); + T1.E1 (I); + END IF; + + IF I /= 1 THEN + FAILED ("WRONG VALUE PASSED"); + END IF; + + END; + + RESULT; +END C95012A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95021a.ada b/gcc/testsuite/ada/acats/tests/c9/c95021a.ada new file mode 100644 index 000000000..a0c047bad --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95021a.ada @@ -0,0 +1,182 @@ +-- C95021A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CALLS TO AN ENTRY ARE PLACED IN A FIFO QUEUE. + +-- JBG 2/22/84 +-- DAS 10/8/90 ADDED PRAGMA PRIORITY TO ENSURE THAT THE FIFO +-- DISCIPLINE MUST BE FOLLOWED (OTHERWISE THE +-- IMPLEMENTATION MIGHT PROHIBIT QUEUES FROM +-- FORMING SO THAT E'COUNT IS ALWAYS ZERO FOR +-- AN ENTRY E). +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +-- THE TASK QUEUE IS THE TASK THAT CHECKS THE QUEUEING DISCIPLINE. +-- +-- THIS TEST PLACES TWO CALLS ON AN ENTRY, WAITS UNTIL ONE OF THE CALLS +-- IS ACCEPTED, AND THEN PLACES A THIRD CALL ON THE ENTRY. THE TEST +-- CHECKS THAT THE SECOND CALL IS HANDLED BEFORE THE THIRD. (IT IS +-- NONDETERMINISTIC WHICH CALL WILL BE THE FIRST ONE ON THE QUEUE, SO +-- THIS MORE COMPLICATED APPROACH IS NECESSARY.) +-- +-- THE TASK DISPATCH FIRES UP THE TWO TASKS THAT MAKE THE FIRST TWO +-- CALLS AND THEN WAITS UNTIL QUEUE SAYS IT IS READY FOR THE THIRD CALL. +-- +-- THE TASK TYPE CALLERS IS USED TO CREATE TASKS THAT WILL CALL THE +-- ENTRY IN THE TASK QUEUE. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; +PROCEDURE C95021A IS +BEGIN + + TEST ("C95021A", "CHECK THAT ENTRY CALLS ARE PUT IN FIFO QUEUES"); + +-- DO THIS TEST 3 TIMES TO ALLOW FOR RANDOM VARIATIONS IN TIMING. + FOR I IN 1..3 LOOP + COMMENT ("ITERATION" & INTEGER'IMAGE(I)); + + DECLARE + + TASK TYPE CALLERS IS + ENTRY NAME (N : NATURAL); + END CALLERS; + + TASK QUEUE IS + ENTRY GO; + ENTRY E1 (NAME : NATURAL); + END QUEUE; + + TASK DISPATCH IS + ENTRY READY; + END DISPATCH; + + TASK BODY CALLERS IS + MY_NAME : NATURAL; + BEGIN + +-- GET NAME OF THIS TASK OBJECT + ACCEPT NAME (N : NATURAL) DO + MY_NAME := N; + END NAME; + +-- PUT THIS TASK ON QUEUE FOR QUEUE.E1 + QUEUE.E1 (MY_NAME); + END CALLERS; + + TASK BODY DISPATCH IS + TYPE ACC_CALLERS IS ACCESS CALLERS; + OBJ : ACC_CALLERS; + BEGIN + +-- FIRE UP TWO CALLERS FOR QUEUE.E1 + OBJ := NEW CALLERS; + OBJ.NAME(1); + OBJ := NEW CALLERS; + OBJ.NAME(2); + +-- ALLOW THESE CALLS TO BE PROCESSED (ONLY ONE WILL BE ACCEPTED). + QUEUE.GO; + +-- WAIT TILL ONE CALL HAS BEEN PROCESSED. + ACCEPT READY; -- CALLED FROM QUEUE + +-- FIRE UP THIRD CALLER + OBJ := NEW CALLERS; + OBJ.NAME(3); + + END DISPATCH; + + TASK BODY QUEUE IS + NEXT : NATURAL; -- NUMBER OF SECOND CALLER IN QUEUE. + BEGIN + +-- WAIT UNTIL TWO TASKS CALLING E1 HAVE BEEN ACTIVATED. + ACCEPT GO; + +-- WAIT FOR TWO CALLS TO BE AVAILABLE. THIS WAIT ASSUMES THAT THE +-- CALLER TASKS WILL PROCEED IF THIS TASK IS EXECUTING A DELAY +-- STATEMENT, ALTHOUGH THIS IS NOT STRICTLY REQUIRED BY THE STANDARD. + FOR I IN 1..6 -- WILL WAIT FOR ONE MINUTE + LOOP + EXIT WHEN E1'COUNT = 2; + DELAY 10.0 * Impdef.One_Second; -- WAIT FOR CALLS TO ARRIVE + END LOOP; + + IF E1'COUNT /= 2 THEN + FAILED ("CALLER TASKS NOT QUEUED AFTER ONE " & + "MINUTE - 1"); + END IF; + +-- ASSUMING NO FAILURE, PROCESS ONE OF THE QUEUED CALLS. + ACCEPT E1 (NAME : NATURAL) DO + +-- GET NAME OF NEXT CALLER + CASE NAME IS + WHEN 1 => + NEXT := 2; + WHEN 2 => + NEXT := 1; + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR"); + END CASE; + END E1; + +-- TELL DISPATCH TO FIRE UP NEXT CALLER (ONE IS STILL IN QUEUE). + DISPATCH.READY; + +-- WAIT FOR CALL TO ARRIVE. + FOR I IN 1..6 -- WILL WAIT FOR ONE MINUTE + LOOP + EXIT WHEN E1'COUNT = 2; + DELAY 10.0 * Impdef.One_Second; -- WAIT FOR CALLS TO ARRIVE + END LOOP; + + IF E1'COUNT /= 2 THEN + FAILED ("CALLER TASKS NOT QUEUED AFTER ONE " & + "MINUTE - 2"); + END IF; + +-- ASSUMING NO FAILURE, ACCEPT SECOND CALL AND CHECK THAT IT IS FROM THE +-- CORRECT TASK. + ACCEPT E1 (NAME : NATURAL) DO + IF NAME /= NEXT THEN + FAILED ("FIFO DISCIPLINE NOT OBEYED"); + END IF; + END E1; + +-- ACCEPT THE LAST CALLER + ACCEPT E1 (NAME : NATURAL); + + END QUEUE; + + BEGIN + NULL; + END; -- ALL TASKS NOW TERMINATED. + END LOOP; + + RESULT; + +END C95021A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95022a.ada b/gcc/testsuite/ada/acats/tests/c9/c95022a.ada new file mode 100644 index 000000000..c7e4bcbe2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95022a.ada @@ -0,0 +1,115 @@ +--C95022A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +--CHECK THAT IT IS POSSIBLE TO ACCEPT AN ENTRY CALL FROM INSIDE THE +--THE BODY OF AN ACCEPT STATEMENT. + +--CHECK THE CASE OF NORMAL ENTRY TERMINATION. + +-- JEAN-PIERRE ROSEN 25-FEB-1984 +-- JBG 6/1/84 + +-- FOUR CLIENT TASKS CALL ONE SERVER TASK. EACH CLIENT CALLS JUST ONE +-- ENTRY OF THE SERVER TASK. THE TEST CHECKS TO BE SURE THAT CALLS FROM +-- DIFFERENT TASKS ARE NOT MIXED UP. + +WITH REPORT; USE REPORT; +PROCEDURE C95022A IS + +BEGIN + TEST("C95022A", "CHECK THAT EMBEDDED RENDEZVOUS ARE PROCESSED " & + "CORRECTLY"); + DECLARE + + TASK TYPE CLIENT IS + ENTRY GET_ID (I : INTEGER); + ENTRY RESTART; + END CLIENT; + + T_ARR : ARRAY (1..4) OF CLIENT; + + TASK SERVER IS + ENTRY E1 (I : IN OUT INTEGER); + ENTRY E2 (I : IN OUT INTEGER); + ENTRY E3 (I : IN OUT INTEGER); + ENTRY E4 (I : IN OUT INTEGER); + END SERVER; + + TASK BODY SERVER IS + BEGIN + + ACCEPT E1 (I : IN OUT INTEGER) DO + ACCEPT E2 (I : IN OUT INTEGER) DO + I := IDENT_INT(I); + ACCEPT E3 (I : IN OUT INTEGER) DO + ACCEPT E4 (I : IN OUT INTEGER) DO + I := IDENT_INT(I); + END E4; + I := IDENT_INT(I); + END E3; + END E2; + I := IDENT_INT(I); + END E1; + + FOR I IN 1 .. 4 LOOP + T_ARR(I).RESTART; + END LOOP; + END SERVER; + + TASK BODY CLIENT IS + ID : INTEGER; + SAVE_ID : INTEGER; + BEGIN + ACCEPT GET_ID (I : INTEGER) DO + ID := I; + END GET_ID; + + SAVE_ID := ID; + + CASE ID IS + WHEN 1 => SERVER.E1(ID); + WHEN 2 => SERVER.E2(ID); + WHEN 3 => SERVER.E3(ID); + WHEN 4 => SERVER.E4(ID); + WHEN OTHERS => FAILED("INCORRECT ID"); + END CASE; + + ACCEPT RESTART; -- WAIT FOR ALL TASKS TO HAVE COMPLETED + -- RENDEZVOUS + IF ID /= SAVE_ID THEN + FAILED("SCRAMBLED EMBEDDED RENDEZVOUS"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED("EXCEPTION IN CLIENT"); + END CLIENT; + + BEGIN + FOR I IN 1 .. 4 LOOP + T_ARR(I).GET_ID(I); + END LOOP; + END; + + RESULT; + +END C95022A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95022b.ada b/gcc/testsuite/ada/acats/tests/c9/c95022b.ada new file mode 100644 index 000000000..cd1e3ff5b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95022b.ada @@ -0,0 +1,112 @@ +-- C95022B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IT IS POSSIBLE TO ACCEPT AN ENTRY CALL FROM INSIDE +-- THE BODY OF AN ACCEPT STATEMENT. + +-- CHECK THE CASE OF ABORT DURING THE INNERMOST ACCEPT. + +-- JEAN-PIERRE ROSEN 25-FEB-1984 +-- JBG 6/1/84 + +WITH REPORT; USE REPORT; +PROCEDURE C95022B IS + +BEGIN + + TEST("C95022B", "CHECK THAT EMBEDDED RENDEZVOUS ARE PROCESSED " & + "CORRECTLY (ABORT CASE)"); + DECLARE + TASK TYPE CLIENT IS + ENTRY GET_ID (I : INTEGER); + END CLIENT; + + T_ARR : ARRAY (1..4) OF CLIENT; + + TASK KILL IS + ENTRY ME; + END KILL; + + TASK SERVER IS + ENTRY E1; + ENTRY E2; + ENTRY E3; + ENTRY E4; + END SERVER; + + TASK BODY SERVER IS + BEGIN + + ACCEPT E1 DO + ACCEPT E2 DO + ACCEPT E3 DO + ACCEPT E4 DO + KILL.ME; + E1; -- WILL DEADLOCK UNTIL ABORT. + END E4; + END E3; + END E2; + END E1; + + END SERVER; + + TASK BODY KILL IS + BEGIN + ACCEPT ME; + ABORT SERVER; + END; + + TASK BODY CLIENT IS + ID : INTEGER; + BEGIN + ACCEPT GET_ID( I : INTEGER) DO + ID := I; + END GET_ID; + + CASE ID IS + WHEN 1 => SERVER.E1; + WHEN 2 => SERVER.E2; + WHEN 3 => SERVER.E3; + WHEN 4 => SERVER.E4; + WHEN OTHERS => FAILED ("INCORRECT ID"); + END CASE; + + FAILED ("TASKING_ERROR NOT RAISED IN CLIENT" & + INTEGER'IMAGE(ID)); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("EXCEPTION IN CLIENT" & INTEGER'IMAGE(ID)); + END CLIENT; + BEGIN + FOR I IN 1 .. 4 LOOP + T_ARR(I).GET_ID(I); + END LOOP; + END; + + RESULT; + +END C95022B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95033a.ada b/gcc/testsuite/ada/acats/tests/c9/c95033a.ada new file mode 100644 index 000000000..53c354856 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95033a.ada @@ -0,0 +1,74 @@ +-- C95033A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT - IN THE CASE OF AN ENTRY FAMILY - EXECUTION OF AN +-- ACCEPT STATEMENT STARTS WITH THE EVALUATION OF AN ENTRY INDEX. + +-- WEI 3/ 4/82 +-- JWC 6/28/85 RENAMED FROM C950BGA-B.ADA + +WITH REPORT; + USE REPORT; +PROCEDURE C95033A IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + FUNCTION FINIT_POS (DIGT: IN ARG) RETURN NATURAL IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + RETURN DIGT; + END FINIT_POS; + + TASK T1 IS + ENTRY E1 (NATURAL RANGE 1 .. 2); + ENTRY BYE; + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (FINIT_POS (1)) DO + PSPY_NUMB (2); + END E1; + ACCEPT BYE; + END T1; + +BEGIN + TEST ("C95033A", "EVALUATION OF ENTRY INDEX"); + + T1.E1 (1); + T1.BYE; + IF SPYNUMB /= 12 THEN + FAILED ("ENTRY INDEX NOT EVALUATED FIRST"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + +END C95033A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95033b.ada b/gcc/testsuite/ada/acats/tests/c9/c95033b.ada new file mode 100644 index 000000000..a72f3b6a8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95033b.ada @@ -0,0 +1,67 @@ +-- C95033B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT EXECUTION OF AN ENTRY CALL STARTS WITH THE EVALUATION OF +-- ANY ENTRY INDEX, FOLLOWED BY THE EVALUATION OF ANY EXPRESSION IN +-- THE PARAMETER LIST. + +-- WEI 3/ 4/82 +-- JWC 6/28/85 RENAMED FROM C950BHA-B.ADA + +WITH REPORT; + USE REPORT; +PROCEDURE C95033B IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + FUNCTION FINIT_POS (DIGT: IN ARG) RETURN NATURAL IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + RETURN DIGT; + END FINIT_POS; + + TASK T1 IS + ENTRY E1 (NATURAL RANGE 1 .. 2) (P1 : IN NATURAL); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (1) (P1 : IN NATURAL); + END T1; + +BEGIN + + TEST ("C95033B", "EVALUATION OF ENTRY INDEX AND OF " & + "EXPRESSIONS IN PARAMETER LIST"); + + T1.E1 (FINIT_POS (1)) (FINIT_POS (2)); + IF SPYNUMB /= 12 THEN + FAILED ("ENTRY INDEX NOT EVALUATED FIRST"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + +END C95033B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95034a.ada b/gcc/testsuite/ada/acats/tests/c9/c95034a.ada new file mode 100644 index 000000000..c597bf25f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95034a.ada @@ -0,0 +1,85 @@ +-- C95034A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A CALLING TASK IS SUSPENDED IF THE RECEIVING TASK +-- HAS NOT REACHED A CORRESPONDING ACCEPT STATEMENT. + +-- WEI 3/ 4/82 +-- JWC 6/28/85 RENAMED FROM C950BJA-B.ADA + +with Impdef; +WITH REPORT; + USE REPORT; +PROCEDURE C95034A IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + TASK T1 IS + ENTRY E1; + ENTRY E2; + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 DO + PSPY_NUMB (1); + DELAY 1.0 * Impdef.One_Second; + END E1; + ACCEPT E2 DO + PSPY_NUMB (2); + END E2; + END T1; + + TASK T2 IS + ENTRY BYE; + END T2; + + TASK BODY T2 IS + BEGIN + T1.E2; + PSPY_NUMB (3); + ACCEPT BYE; + END T2; + +BEGIN + + TEST ("C95034A", "SUSPENSION OF CALLING TASK"); + + T1.E1; + T2.BYE; + + IF SPYNUMB /= 123 THEN + FAILED ("ERROR DURING TASK EXECUTION"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + +END C95034A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95034b.ada b/gcc/testsuite/ada/acats/tests/c9/c95034b.ada new file mode 100644 index 000000000..3c491e70a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95034b.ada @@ -0,0 +1,83 @@ +-- C95034B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A CALLING TASK REMAINS SUSPENDED UNTIL THE ACCEPT +-- STATEMENT RECEIVING THIS ENTRY CALL HAS COMPLETED THE EXECUTION OF +-- ITS SEQUENCE OF STATEMENTS. + +-- WEI 3/ 4/82 +-- JWC 6/28/85 RENAMED FROM C950CBA-B.ADA + +with Impdef; +WITH REPORT; + USE REPORT; +PROCEDURE C95034B IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 DO + PSPY_NUMB (1); + DELAY 1.0 * Impdef.One_Second; + PSPY_NUMB (2); + END E1; + END T1; + + TASK T2 IS + ENTRY BYE; + END T2; + + TASK BODY T2 IS + BEGIN + T1.E1; + PSPY_NUMB (3); + ACCEPT BYE; + END T2; + +BEGIN + + TEST ("C95034B", "TASK SUSPENSION UNTIL COMPLETION OF ACCEPT " & + "STATEMENT"); + + T2.BYE; + + IF SPYNUMB /= 123 THEN + FAILED ("ERROR DURING TASK EXECUTION"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + +END C95034B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95035a.ada b/gcc/testsuite/ada/acats/tests/c9/c95035a.ada new file mode 100644 index 000000000..ce7816628 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95035a.ada @@ -0,0 +1,78 @@ +-- C95035A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TASK IS SUSPENDED IF IT REACHES AN ACCEPT STATEMENT +-- PRIOR TO ANY CALL OF THE CORRESPONDING ENTRY. + +-- WEI 3/ 4/82 +-- JWC 6/28/85 RENAMED FROM C950CAA-B.ADA + +with Impdef; +WITH REPORT; + USE REPORT; +PROCEDURE C95035A IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + TASK T1 IS + ENTRY E1; + ENTRY BYE; + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1; + PSPY_NUMB (2); + ACCEPT BYE; + END T1; + + TASK T2; + + TASK BODY T2 IS + BEGIN + DELAY 1.0 * Impdef.One_Second; + PSPY_NUMB (1); + T1.E1; + END T2; + +BEGIN + + TEST ("C95035A", "TASK SUSPENSION PRIOR TO ENTRY CALL"); + + T1.BYE; + + IF SPYNUMB /= 12 THEN + FAILED ("ERROR DURING TASK EXECUTION"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + +END C95035A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95040a.ada b/gcc/testsuite/ada/acats/tests/c9/c95040a.ada new file mode 100644 index 000000000..aa302bd1e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95040a.ada @@ -0,0 +1,59 @@ +-- C95040A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE EXCEPTION TASKING_ERROR IS RAISED IF AN ENTRY OF A +-- COMPLETED TASK IS CALLED. + +-- WEI 3/ 4/82 +-- JWC 6/28/85 RENAMED FROM C950CHA-B.ADA + +WITH REPORT; + USE REPORT; +PROCEDURE C95040A IS +BEGIN + + TEST ("C95040A", "ENTRY CALL OF COMPLETED TASK"); + +BLOCK1 : + DECLARE + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1; + END T1; + BEGIN -- BLOCK1 + T1.E1; + T1.E1; + + FAILED ("DID NOT RAISE TASKING_ERROR"); + EXCEPTION + WHEN TASKING_ERROR => NULL; + END BLOCK1; + + RESULT; + +END C95040A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95040b.ada b/gcc/testsuite/ada/acats/tests/c9/c95040b.ada new file mode 100644 index 000000000..aee275f28 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95040b.ada @@ -0,0 +1,63 @@ +-- C95040B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE EXCEPTION TASKING_ERROR IS RAISED BY A TASK IF THE +-- TASK BECOMES COMPLETED OR ABNORMAL BEFORE ACCEPTING THE CALL. + +-- WEI 3/ 4/82 +-- TLB 10/30/87 RENAMED FROM C950CHC.ADA. + +with Impdef; +WITH REPORT; + USE REPORT; +PROCEDURE C95040B IS + + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + BEGIN + DELAY 1.0 * Impdef.One_Second; + IF EQUAL (1, 1) THEN + ABORT T1; + END IF; + ACCEPT E1; + END T1; + +BEGIN + + TEST ("C95040B", "TASK COMPLETION BEFORE ACCEPTING AN ENTRY CALL"); + + T1.E1; + + FAILED ("NO EXCEPTION TASKING_ERROR RAISED"); + + RESULT; + +EXCEPTION + WHEN TASKING_ERROR => + RESULT; + +END C95040B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95040c.ada b/gcc/testsuite/ada/acats/tests/c9/c95040c.ada new file mode 100644 index 000000000..cc7db5804 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95040c.ada @@ -0,0 +1,86 @@ +-- C95040C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECKS THAT A TASK COMPLETED, BUT NOT TERMINATED (I.E. WAITING +-- FOR TERMINATION OF A DEPENDENT TASK) IS NEITHER 'TERMINATED NOR +-- 'CALLABLE. CALLS TO ENTRIES BELONGING TO SUCH A TASK RAISE +-- TASKING_ERROR. + +-- J.P. ROSEN, ADA PROJECT, NYU +-- JBG 6/1/84 +-- JWC 6/28/85 RENAMED FROM C9A009A-B.ADA +-- PWN 9/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C95040C IS +BEGIN + + TEST ("C95040C", "TASKING_ERROR RAISED WHEN CALLING COMPLETED " & + "BUT UNTERMINATED TASK"); + + DECLARE + + TASK T1 IS + ENTRY E; + END T1; + + TASK BODY T1 IS + + TASK T2 IS + END T2; + + TASK BODY T2 IS + BEGIN + COMMENT ("BEGIN T2"); + T1.E; -- T1 WILL COMPLETE BEFORE THIS CALL + -- OR WHILE WAITING FOR THIS CALL TO + -- BE ACCEPTED. WILL DEADLOCK IF + -- TASKING_ERROR IS NOT RAISED. + FAILED ("NO TASKING_ERROR RAISED"); + EXCEPTION + WHEN TASKING_ERROR => + IF T1'CALLABLE THEN + FAILED ("T1 STILL CALLABLE"); + END IF; + + IF T1'TERMINATED THEN -- T1 CAN'T TERMINATE + -- UNTIL T2 HAS + -- TERMINATED. + FAILED ("T1 TERMINATED"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION"); + END T2; + BEGIN + NULL; + END; + + BEGIN + NULL; + END; + + RESULT; + +END C95040C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95040d.ada b/gcc/testsuite/ada/acats/tests/c9/c95040d.ada new file mode 100644 index 000000000..cfe0a772d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95040d.ada @@ -0,0 +1,122 @@ +-- C95040D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT TASKING_ERROR IS RAISED IN A CALLING +-- TASK WHEN THE TASK OWNING THE ENTRY TERMINATES BEFORE RENDEZVOUS +-- CAN OCCUR. + +-- CHECK THAT RE-RAISING TASKING_ERROR, ONCE TRAPPED IN THE CALLER, +-- DOES NOT PROPAGATE OUTSIDE THE TASK BODY. + +-- GOM 11/29/84 +-- JWC 05/14/85 +-- PWB 02/11/86 CORRECTED CALL TO TEST TO SHOW CORRECT TEST NAME. +-- RLB 12/15/99 REMOVED POTENTIALLY ERRONEOUS CALLS TO REPORT.COMMENT. + +WITH REPORT; +USE REPORT; + +PROCEDURE C95040D IS + + PROCEDURE DRIVER IS + + TASK NEST IS + ENTRY OUTER; + ENTRY INNER; + END NEST; + + TASK SLAVE; + + TASK BODY NEST IS + BEGIN + --COMMENT("AT TOP OF 'NEST' TASK WAITING ON 'OUTER' " & + -- "RENDEZVOUS"); + + ACCEPT OUTER DO + --COMMENT("IN 'OUTER' RENDEZVOUS OF 'NEST' TASK " & + -- "ABOUT TO 'RETURN'"); + + RETURN; -- CAUSES 'INNER' RENDEZVOUS TO BE SKIPPED. + + ACCEPT INNER DO + FAILED("'INNER' RENDEZVOUS OF 'NEST' TASK " & + "SHOULD NEVER BE PERFORMED"); + END INNER; + END OUTER; + + --COMMENT("'OUTER' RENDEZVOUS COMPLETED IN 'NEST' TASK " & + -- "AND NOW TERMINATING"); + END NEST; + + TASK BODY SLAVE IS + BEGIN + --COMMENT("AT TOP OF 'SLAVE' TASK. CALLING 'INNER' " & + -- "RENDEZVOUS"); + + NEST.INNER; + + FAILED("SHOULD HAVE RAISED 'TASKING_ERROR' IN 'SLAVE' " & + "TASK"); + EXCEPTION + WHEN TASKING_ERROR => + --COMMENT("'SLAVE' TASK CORRECTLY TRAPPING " & + -- "'TASKING_ERROR' AND RE-RAISING IT (BUT " & + -- "SHOULD NOT BE PROPAGATED)"); + RAISE; + END SLAVE; + + BEGIN -- START OF DRIVER PROCEDURE. + + --COMMENT("AT TOP OF 'DRIVER'. CALLING 'OUTER' ENTRY OF " & + -- "'NEST' TASK"); + + NEST.OUTER; + + --COMMENT("'OUTER' RENDEZVOUS COMPLETED. 'DRIVER' AWAITING " & + -- "TERMINATION OF 'NEST' AND 'SLAVE' TASKS"); + + EXCEPTION + WHEN TASKING_ERROR => + FAILED("'TASKING_ERROR' CAUGHT IN 'DRIVER' WHEN IT " & + "SHOULD HAVE BEEN CAUGHT IN 'SLAVE' TASK, OR " & + "'TASKING_ERROR' WAS INCORRECTLY PROPAGATED BY " & + "'SLAVE' TASK"); + END DRIVER; + +BEGIN -- START OF MAIN PROGRAM. + + TEST("C95040D","CHECK THAT 'TASKING_ERROR' IS RAISED IN A " & + "CALLER TASK WHEN TASK OWNING THE ENTRY CANNOT " & + "PERFORM RENDEZVOUS. ALSO CHECK THAT " & + "'TASKING_ERROR', ONCE RAISED, IS NOT PROPAGATED " & + "OUTSIDE THE TASK BODY"); + + --COMMENT("MAIN PROGRAM CALLING 'DRIVER' PROCEDURE"); + + DRIVER; + + --COMMENT("MAIN PROGRAM NOW TERMINATING"); + + RESULT; +END C95040D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95041a.ada b/gcc/testsuite/ada/acats/tests/c9/c95041a.ada new file mode 100644 index 000000000..4f676b3c4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95041a.ada @@ -0,0 +1,97 @@ +-- C95041A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT AN ENTRY FAMILY INDEX CAN BE SPECIFIED WITH THE FORM +-- A'RANGE. + +-- HISTORY: +-- DHH 03/17/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C95041A IS + + GLOBAL_A, GLOBAL_B : INTEGER; + GLOBAL_C, GLOBAL_D : INTEGER; + TYPE COLOR IS (RED, BLUE, YELLOW); + TYPE ARR IS ARRAY(COLOR RANGE RED .. BLUE) OF BOOLEAN; + ARRY : ARR; + + TASK CHECK IS + ENTRY CHECK_LINK(ARR'RANGE)(I : INTEGER); + END CHECK; + + TASK CHECK_OBJ IS + ENTRY CHECK_OBJ_LINK(ARRY'RANGE)(I : INTEGER); + END CHECK_OBJ; + + TASK BODY CHECK IS + BEGIN + ACCEPT CHECK_LINK(RED)(I : INTEGER) DO + GLOBAL_A := IDENT_INT(I); + END; + + ACCEPT CHECK_LINK(BLUE)(I : INTEGER) DO + GLOBAL_B := IDENT_INT(I); + END; + END CHECK; + + TASK BODY CHECK_OBJ IS + BEGIN + ACCEPT CHECK_OBJ_LINK(RED)(I : INTEGER) DO + GLOBAL_C := IDENT_INT(I); + END; + + ACCEPT CHECK_OBJ_LINK(BLUE)(I : INTEGER) DO + GLOBAL_D := IDENT_INT(I); + END; + END CHECK_OBJ; + +BEGIN + TEST("C95041A", "CHECK THAT AN ENTRY FAMILY INDEX CAN BE " & + "SPECIFIED WITH THE FORM A'RANGE"); + CHECK.CHECK_LINK(RED)(10); + CHECK.CHECK_LINK(BLUE)(5); + + CHECK_OBJ.CHECK_OBJ_LINK(RED)(10); + CHECK_OBJ.CHECK_OBJ_LINK(BLUE)(5); + + IF GLOBAL_A /= IDENT_INT(10) THEN + FAILED("ENTRY CHECK_LINK(RED) HAS INCORRECT VALUE"); + END IF; + + IF GLOBAL_B /= IDENT_INT(5) THEN + FAILED("ENTRY CHECK_LINK(BLUE) HAS INCORRECT VALUE"); + END IF; + + IF GLOBAL_C /= IDENT_INT(10) THEN + FAILED("ENTRY CHECK_LINK(RED) HAS INCORRECT VALUE"); + END IF; + + IF GLOBAL_D /= IDENT_INT(5) THEN + FAILED("ENTRY CHECK_LINK(BLUE) HAS INCORRECT VALUE"); + END IF; + + RESULT; +END C95041A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95065a.ada b/gcc/testsuite/ada/acats/tests/c9/c95065a.ada new file mode 100644 index 000000000..2224dddcd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95065a.ada @@ -0,0 +1,91 @@ +-- C95065A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED +-- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES +-- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE +-- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED. + +-- CASE (A) ARRAY PARAMETERS CONSTRAINED WITH NONSTATIC BOUNDS AND +-- INITIALIZED WITH A STATIC AGGREGATE. + +-- JWC 6/19/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95065A IS + +BEGIN + + TEST ("C95065A", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " & + "AN INITIALIZATION VALUE DOES NOT SATISFY " & + "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " & + "FORMAL PART IS ELABORATED"); + + BEGIN + + DECLARE + + TYPE A1 IS ARRAY (1 .. IDENT_INT(1), 1 .. IDENT_INT(10)) + OF INTEGER; + + TASK T IS + ENTRY E1 (A : A1 := ((1, 0), (0, 1))); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E1 (A : A1 := ((1, 0), (0, 1))) DO + FAILED ("ACCEPT E1 EXECUTED"); + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK T"); + END T; + + BEGIN + T.E1; + FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - E1"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + +END C95065A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95065b.ada b/gcc/testsuite/ada/acats/tests/c9/c95065b.ada new file mode 100644 index 000000000..81226af3a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95065b.ada @@ -0,0 +1,91 @@ +-- C95065B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED +-- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES +-- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE +-- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED. + +-- CASE (B) A SCALAR PARAMETER WITH NON-STATIC RANGE CONSTRAINTS +-- INITIALIZED WITH A STATIC VALUE. + +-- JWC 6/19/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95065B IS + +BEGIN + + TEST ("C95065B", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " & + "AN INITIALIZATION VALUE DOES NOT SATISFY " & + "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " & + "FORMAL PART IS ELABORATED"); + + BEGIN + + DECLARE + + SUBTYPE INT IS INTEGER + RANGE IDENT_INT(0) .. IDENT_INT(63); + + TASK T IS + ENTRY E1 (I : INT := -1); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E1 (I : INT := -1) DO + FAILED ("ACCEPT E1 EXECUTED"); + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK T"); + END T; + + BEGIN + T.E1; + FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - E1"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + +END C95065B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95065c.ada b/gcc/testsuite/ada/acats/tests/c9/c95065c.ada new file mode 100644 index 000000000..3a7732e87 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95065c.ada @@ -0,0 +1,97 @@ +-- C95065C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED +-- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES +-- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE +-- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED. + +-- CASE (C) A RECORD PARAMETER WHOSE COMPONENTS HAVE NON-STATIC +-- CONSTRAINTS INITIALIZED WITH A STATIC AGGREGATE. + +-- JWC 6/19/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95065C IS + +BEGIN + + TEST ("C95065C", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " & + "AN INITIALIZATION VALUE DOES NOT SATISFY " & + "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " & + "FORMAL PART IS ELABORATED"); + + BEGIN + + DECLARE + + TYPE A1 IS ARRAY (1 .. 3) OF INTEGER + RANGE IDENT_INT(1) .. IDENT_INT(3); + + TYPE REC IS + RECORD + I : INTEGER RANGE IDENT_INT(1)..IDENT_INT(3); + A : A1; + END RECORD; + + TASK T IS + ENTRY E1 (R : REC := (-3,(0,2,3))); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E1 (R : REC := (-3,(0,2,3))) DO + FAILED ("ACCEPT E1 EXECUTED"); + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK T"); + END T; + + BEGIN + T.E1; + FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - E1"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + +END C95065C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95065d.ada b/gcc/testsuite/ada/acats/tests/c9/c95065d.ada new file mode 100644 index 000000000..36fc22c27 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95065d.ada @@ -0,0 +1,92 @@ +-- C95065D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED +-- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES +-- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE +-- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED. + +-- CASE (D) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON +-- SUBSCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED +-- WITH A STATIC AGGREGATE. + +-- JWC 6/19/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95065D IS + +BEGIN + + TEST ("C95065D", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " & + "AN INITIALIZATION VALUE DOES NOT SATISFY " & + "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " & + "FORMAL PART IS ELABORATED"); + + BEGIN + + DECLARE + + TYPE A1 IS ARRAY (1 .. 2, 1 .. 2) OF INTEGER + RANGE IDENT_INT(1) .. IDENT_INT(2); + + TASK T IS + ENTRY E1 (A : A1 := ((1, -1), (1, 2))); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E1 (A : A1 := ((1, -1), (1, 2))) DO + FAILED ("ACCEPT E1 EXECUTED"); + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK T"); + END T; + + BEGIN + T.E1; + FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - E1"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + +END C95065D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95065e.ada b/gcc/testsuite/ada/acats/tests/c9/c95065e.ada new file mode 100644 index 000000000..95086f073 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95065e.ada @@ -0,0 +1,92 @@ +-- C95065E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED +-- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES +-- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE +-- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED. + +-- CASE (E) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON +-- SUBSCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED +-- WITH A STATIC AGGREGATE. + +-- JWC 6/19/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95065E IS + +BEGIN + + TEST ("C95065E", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " & + "AN INITIALIZATION VALUE DOES NOT SATISFY " & + "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " & + "FORMAL PART IS ELABORATED"); + + BEGIN + + DECLARE + + TYPE A1 IS ARRAY (1 .. 2, 1 .. 2) OF INTEGER + RANGE IDENT_INT(1) .. IDENT_INT(2); + + TASK T IS + ENTRY E1 (A : A1 := (3 .. 4 => (1, 2))); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E1 (A : A1 := (3 .. 4 => (1, 2))) DO + FAILED ("ACCEPT E1 EXECUTED"); + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK T"); + END T; + + BEGIN + T.E1; + FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - E1"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + +END C95065E; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95065f.ada b/gcc/testsuite/ada/acats/tests/c9/c95065f.ada new file mode 100644 index 000000000..3451707af --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95065f.ada @@ -0,0 +1,97 @@ +-- C95065F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED +-- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES +-- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE +-- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED. + +-- CASE (F) A RECORD PARAMETER WITH A NON-STATIC CONSTRAINT +-- INITIALIZED WITH A STATIC AGGREGATE. + +-- JWC 6/19/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95065F IS + +BEGIN + + TEST ("C95065F", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " & + "AN INITIALIZATION VALUE DOES NOT SATISFY " & + "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " & + "FORMAL PART IS ELABORATED"); + + BEGIN + + DECLARE + + SUBTYPE INT IS INTEGER RANGE 0 .. 10; + TYPE A1 IS ARRAY (1 .. 3) OF INT; + TYPE REC (I : INT) IS + RECORD + A : A1; + END RECORD; + + SUBTYPE REC4 IS REC (IDENT_INT(4)); + + TASK T IS + ENTRY E1 (R : REC4 := (3,(1,2,3))); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E1 (R : REC4 := (3,(1,2,3))) DO + FAILED ("ACCEPT E1 EXECUTED"); + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK T"); + END T; + + BEGIN + T.E1; + FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - E1"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + +END C95065F; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95066a.ada b/gcc/testsuite/ada/acats/tests/c9/c95066a.ada new file mode 100644 index 000000000..f9405d99b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95066a.ada @@ -0,0 +1,214 @@ +-- C95066A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A STATIC EXPRESSION, CONSTANT NAME, ATTRIBUTE NAME, +-- VARIABLE, DEREFERENCED ACCESS, USER-DEFINED OPERATOR, USER- +-- DEFINED FUNCTION, OR ALLOCATOR CAN BE USED IN THE INITIALIZATION +-- EXPRESSION OF A FORMAL PARAMETER, AND THAT THE APPROPRIATE +-- VALUE IS USED AS A DEFAULT PARAMETER VALUE WHEN THE ENTRY +-- IS CALLED. + +-- GLH 6/19/85 + +WITH REPORT; +PROCEDURE C95066A IS + + USE REPORT; + + TYPE INT IS RANGE 1 .. 10; + + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + + TYPE RECTYPE (CONSTRAINT : INTEGER) IS + RECORD + A : ARR (0..CONSTRAINT); + END RECORD; + + C7 : CONSTANT INTEGER := 7; + V7 : INTEGER := 7; + + TYPE A_INT IS ACCESS INTEGER; + C_A : CONSTANT A_INT := NEW INTEGER'(7); + + SUBTYPE RECTYPE1 IS RECTYPE (2 + 5); + SUBTYPE RECTYPE2 IS RECTYPE (C7); + SUBTYPE RECTYPE3 IS RECTYPE (V7); + + FUNCTION "&" (X,Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN 10; + END "&"; + + FUNCTION FUNC (X : INTEGER) RETURN INTEGER IS + BEGIN + RETURN X; + END FUNC; + + -- STATIC EXPRESSION. + + TASK T1 IS + ENTRY E1 (REC : RECTYPE1 := (3+4,(0,1,2,3,4,5,6,7))); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (REC : RECTYPE1 := (3+4,(0,1,2,3,4,5,6,7))) DO + IF (REC /= (7,(0,1,2,3,4,5,6,7))) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR " & + "E1 PARAMETER"); + END IF; + END E1; + END T1; + + -- CONSTANT NAME. + + TASK T2 IS + ENTRY E2 (REC : RECTYPE2 := (C7,(0,1,2,3,4,5,6,7))); + END T2; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (REC : RECTYPE2 := (C7,(0,1,2,3,4,5,6,7))) DO + IF (REC /= (C7,(0,1,2,3,4,5,6,7))) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR " & + "E2 PARAMETER"); + END IF; + END E2; + END T2; + + -- ATTRIBUTE NAME. + + TASK T3 IS + ENTRY E3 (P1 : INT := INT'LAST); + END T3; + + TASK BODY T3 IS + BEGIN + ACCEPT E3 (P1 : INT := INT'LAST) DO + IF (P1 /= INT (10)) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR " & + "E3 PARAMETER"); + END IF; + END E3; + END T3; + + -- VARIABLE. + + TASK T4 IS + ENTRY E4 (P4 : RECTYPE3 := (V7,(0,1,2,3,4,5,6,7))); + END T4; + + TASK BODY T4 IS + BEGIN + ACCEPT E4 (P4 : RECTYPE3 := (V7,(0,1,2,3,4,5,6,7))) DO + IF (P4 /= (V7,(0,1,2,3,4,5,6,7))) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR " & + "E4 PARAMETER"); + END IF; + END E4; + END T4; + + -- DEREFERENCED ACCESS. + + TASK T5 IS + ENTRY E5 (P5 : INTEGER := C_A.ALL); + END T5; + + TASK BODY T5 IS + BEGIN + ACCEPT E5 (P5 : INTEGER := C_A.ALL) DO + IF (P5 /= C_A.ALL) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR " & + "E5 PARAMETER"); + END IF; + END E5; + END T5; + + -- USER-DEFINED OPERATOR. + + TASK T6 IS + ENTRY E6 (P6 : INTEGER := 6&4); + END T6; + + TASK BODY T6 IS + BEGIN + ACCEPT E6 (P6 : INTEGER := 6&4) DO + IF (P6 /= IDENT_INT(10)) THEN + FAILED ("INCORRECT DEFAULT VALUE " & + "FOR E6 PARAMETER"); + END IF; + END E6; + END T6; + + -- USER-DEFINED FUNCTION. + + TASK T7 IS + ENTRY E7 (P7 : INTEGER := FUNC(10)); + END T7; + + TASK BODY T7 IS + BEGIN + ACCEPT E7 (P7 : INTEGER := FUNC(10)) DO + IF (P7 /= IDENT_INT(10)) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR " & + "E7 PARAMETER"); + END IF; + END E7; + END T7; + + -- ALLOCATOR. + + TASK T8 IS + ENTRY E8 (P8 : A_INT := NEW INTEGER'(7)); + END T8; + + TASK BODY T8 IS + BEGIN + ACCEPT E8 (P8 : A_INT := NEW INTEGER'(7)) DO + IF (P8.ALL /= IDENT_INT(7)) THEN + FAILED ("INCORRECT DEFAULT VALUE " & + "FOR E8 PARAMETER"); + END IF; + END E8; + END T8; + +BEGIN + TEST ("C95066A", "CHECK USE OF STATIC EXPRESSIONS, CONSTANT " & + "NAMES, ATTRIBUTE NAMES, VARIABLES, USER- " & + "DEFINED OPERATORS, USER-DEFINED FUNCTIONS, " & + "DEREFERENCED ACCESSES, AND ALLOCATORS IN " & + "THE FORMAL PART OF A TASK SPECIFICATION"); + + T1.E1; + T2.E2; + T3.E3; + T4.E4; + T5.E5; + T6.E6; + T7.E7; + T8.E8; + + RESULT; + +END C95066A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95067a.ada b/gcc/testsuite/ada/acats/tests/c9/c95067a.ada new file mode 100644 index 000000000..d4393d51d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95067a.ada @@ -0,0 +1,302 @@ +-- C95067A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A FORMAL PARAMETER OF MODE IN OR IN OUT CAN BE OF A +-- LIMITED TYPE, INCLUDING A COMPOSITE LIMITED TYPE. + +-- JWC 6/20/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95067A IS + + PACKAGE PKG IS + + TYPE ITYPE IS LIMITED PRIVATE; + + TASK T1 IS + + ENTRY LOOK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING); + + ENTRY LOOK_INOUT_I (X : IN OUT ITYPE; V : INTEGER; + M : STRING); + + ENTRY SET_I (X : IN OUT ITYPE; V : INTEGER); + + END T1; + + SUBTYPE INT_0_20 IS INTEGER RANGE 0 .. 20; + TYPE VRTYPE (C : INT_0_20 := 20) IS LIMITED PRIVATE; + + TASK T2 IS + + ENTRY LOOK_IN_VR (X : IN VRTYPE; C : INTEGER; + I : INTEGER; S : STRING; M : STRING); + + ENTRY LOOK_INOUT_VR (X : IN OUT VRTYPE; C : INTEGER; + I : INTEGER; S : STRING; + M : STRING); + + ENTRY SET_VR (X : IN OUT VRTYPE; C : INTEGER; + I : INTEGER; S : STRING); + + END T2; + + PRIVATE + + TYPE ITYPE IS NEW INTEGER RANGE 0 .. 99; + + TYPE VRTYPE (C : INT_0_20 := 20) IS + RECORD + I : INTEGER; + S : STRING (1 .. C); + END RECORD; + + END PKG; + + USE PKG; + + I1 : ITYPE; + + TYPE ATYPE IS ARRAY (1 .. 3) OF ITYPE; + + A1 : ATYPE; + + VR1 : VRTYPE; + + D : CONSTANT INT_0_20 := 10; + + TYPE RTYPE IS + RECORD + J : ITYPE; + R : VRTYPE (D); + END RECORD; + + R1 : RTYPE; + + PACKAGE BODY PKG IS + + TASK BODY T1 IS + BEGIN + LOOP + SELECT + ACCEPT LOOK_IN_I (X : IN ITYPE; V : INTEGER; + M : STRING) DO + IF INTEGER (X) /= V THEN + FAILED ("WRONG SCALAR VALUE - " & M); + END IF; + END LOOK_IN_I; + OR + ACCEPT LOOK_INOUT_I (X : IN OUT ITYPE; + V : INTEGER; + M : STRING) DO + IF INTEGER (X) /= V THEN + FAILED ("WRONG SCALAR VALUE - " & M); + END IF; + END LOOK_INOUT_I; + OR + ACCEPT SET_I (X : IN OUT ITYPE; V : INTEGER) DO + X := ITYPE (IDENT_INT (V)); + END SET_I; + OR + TERMINATE; + END SELECT; + END LOOP; + END T1; + + TASK BODY T2 IS + BEGIN + LOOP + SELECT + ACCEPT LOOK_IN_VR (X : IN VRTYPE; C : INTEGER; + I : INTEGER; S : STRING; + M : STRING) DO + IF (X.C /= C OR X.I /= I) OR ELSE + X.S /= S THEN + FAILED ("WRONG COMPOSITE VALUE - " & + M); + END IF; + END LOOK_IN_VR; + OR + ACCEPT LOOK_INOUT_VR (X : IN OUT VRTYPE; + C : INTEGER; I : INTEGER; + S : STRING; + M : STRING) DO + IF (X.C /= C OR X.I /= I) OR ELSE + X.S /= S THEN + FAILED ("WRONG COMPOSITE VALUE - " & + M); + END IF; + END LOOK_INOUT_VR; + OR + ACCEPT SET_VR (X : IN OUT VRTYPE; C : INTEGER; + I : INTEGER; S : STRING) DO + X := (IDENT_INT(C), IDENT_INT(I), + IDENT_STR(S)); + END SET_VR; + OR + TERMINATE; + END SELECT; + END LOOP; + END T2; + + BEGIN + I1 := ITYPE (IDENT_INT(2)); + + FOR I IN A1'RANGE LOOP + A1 (I) := ITYPE (3 + IDENT_INT(I)); + END LOOP; + + VR1 := (IDENT_INT(5), IDENT_INT(4), IDENT_STR("01234")); + + R1.J := ITYPE (IDENT_INT(6)); + R1.R := (IDENT_INT(D), IDENT_INT(19), + IDENT_STR("ABCDEFGHIJ")); + END PKG; + + TASK T3 IS + ENTRY CHECK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING); + + ENTRY CHECK_INOUT_I (X : IN OUT ITYPE; OV : INTEGER; + NV : INTEGER; M : STRING); + + ENTRY CHECK_IN_A (X : IN ATYPE; V : INTEGER; M : STRING); + + ENTRY CHECK_INOUT_A (X : IN OUT ATYPE; OV : INTEGER; + NV : INTEGER; M : STRING); + + ENTRY CHECK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER; + S : STRING; M : STRING); + + ENTRY CHECK_INOUT_VR (X : IN OUT VRTYPE; + OC : INTEGER; OI : INTEGER; OS : STRING; + NC : INTEGER; NI : INTEGER; NS : STRING; + M : STRING); + + ENTRY CHECK_IN_R (X : IN RTYPE; J : INTEGER; C : INTEGER; + I : INTEGER; S : STRING; M : STRING); + + ENTRY CHECK_INOUT_R (X : IN OUT RTYPE; OJ : INTEGER; + OC : INTEGER; OI : INTEGER; OS : STRING; + NJ : INTEGER; + NC : INTEGER; NI : INTEGER; NS : STRING; + M : STRING); + END T3; + + TASK BODY T3 IS + BEGIN + ACCEPT CHECK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING) DO + T1.LOOK_IN_I (X, V, M); + END CHECK_IN_I; + + ACCEPT CHECK_INOUT_I (X : IN OUT ITYPE; OV : INTEGER; + NV : INTEGER; M : STRING) DO + T1.LOOK_INOUT_I (X, OV, M & " - A"); + T1.SET_I (X, NV); + T1.LOOK_INOUT_I (X, NV, M & " - B"); + T1.LOOK_IN_I (X, NV, M & " - C"); + END CHECK_INOUT_I; + + ACCEPT CHECK_IN_A (X : IN ATYPE; V : INTEGER; M : STRING) DO + FOR I IN X'RANGE LOOP + T1.LOOK_IN_I (X(I), V+I, M & " -" & + INTEGER'IMAGE (I)); + END LOOP; + END CHECK_IN_A; + + ACCEPT CHECK_INOUT_A (X : IN OUT ATYPE; OV : INTEGER; + NV : INTEGER; M : STRING) DO + FOR I IN X'RANGE LOOP + T1.LOOK_INOUT_I (X(I), OV+I, M & " - A" & + INTEGER'IMAGE (I)); + T1.SET_I (X(I), NV+I); + T1.LOOK_INOUT_I (X(I), NV+I, M & " - B" & + INTEGER'IMAGE (I)); + T1.LOOK_IN_I (X(I), NV+I, M & " - C" & + INTEGER'IMAGE (I)); + END LOOP; + END CHECK_INOUT_A; + + ACCEPT CHECK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER; + S : STRING; M : STRING) DO + T2.LOOK_IN_VR (X, C, I, S, M); + END CHECK_IN_VR; + + ACCEPT CHECK_INOUT_VR (X : IN OUT VRTYPE; + OC : INTEGER; OI : INTEGER; + OS : STRING; + NC : INTEGER; NI : INTEGER; + NS : STRING; + M : STRING) DO + T2.LOOK_INOUT_VR (X, OC, OI, OS, M & " - A"); + T2.SET_VR (X, NC, NI, NS); + T2.LOOK_INOUT_VR (X, NC, NI, NS, M & " - B"); + T2.LOOK_IN_VR (X, NC, NI, NS, M & " - C"); + END CHECK_INOUT_VR; + + ACCEPT CHECK_IN_R (X : IN RTYPE; J : INTEGER; C : INTEGER; + I : INTEGER; S : STRING; M : STRING) DO + T1.LOOK_IN_I (X.J, J, M & " - A"); + T2.LOOK_IN_VR (X.R, C, I, S, M & " - B"); + END CHECK_IN_R; + + ACCEPT CHECK_INOUT_R (X : IN OUT RTYPE; OJ : INTEGER; + OC : INTEGER; OI : INTEGER; OS : STRING; + NJ : INTEGER; + NC : INTEGER; NI : INTEGER; NS : STRING; + M : STRING) DO + T1.LOOK_INOUT_I (X.J, OJ, M & " - A"); + T2.LOOK_INOUT_VR (X.R, OC, OI, OS, M & " - B"); + T1.SET_I (X.J, NJ); + T2.SET_VR (X.R, NC, NI, NS); + T1.LOOK_INOUT_I (X.J, NJ, M & " - C"); + T2.LOOK_INOUT_VR (X.R, NC, NI, NS, M & " - D"); + T1.LOOK_IN_I (X.J, NJ, M & " - E"); + T2.LOOK_IN_VR (X.R, NC, NI, NS, M & " - F"); + END CHECK_INOUT_R; + END T3; + +BEGIN + TEST ("C95067A", "CHECK THAT LIMITED PRIVATE/COMPOSITE TYPES " & + "CAN BE USED AS IN OR IN OUT FORMAL PARAMETERS"); + + T3.CHECK_IN_I (I1, 2, "IN I"); + + T3.CHECK_INOUT_I (I1, 2, 5, "INOUT I"); + + T3.CHECK_IN_A (A1, 3, "IN A"); + + T3.CHECK_INOUT_A (A1, 3, 17, "INOUT A"); + + T3.CHECK_IN_VR (VR1, 5, 4, "01234", "IN VR"); + + T3.CHECK_INOUT_VR (VR1, 5, 4, "01234", 10, 11, "9876543210", + "INOUT VR"); + + T3.CHECK_IN_R (R1, 6, D, 19, "ABCDEFGHIJ", "IN R"); + + T3.CHECK_INOUT_R (R1, 6, D, 19, "ABCDEFGHIJ", 13, D, 5, + "ZYXWVUTSRQ", "INOUT R"); + + RESULT; +END C95067A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95071a.ada b/gcc/testsuite/ada/acats/tests/c9/c95071a.ada new file mode 100644 index 000000000..a7153993d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95071a.ada @@ -0,0 +1,230 @@ +-- C95071A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT OBJECTS DESIGNATED BY IN PARAMETERS OF ACCESS TYPES CAN +-- BE USED AS THE TARGET OF AN ASSIGNMENT STATEMENT AND AS AN ACTUAL +-- PARAMETER OF ANY MODE. SUBTESTS ARE: +-- (A) INTEGER ACCESS TYPE. +-- (B) ARRAY ACCESS TYPE. +-- (C) RECORD ACCESS TYPE. + +-- JWC 7/11/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95071A IS + +BEGIN + + TEST ("C95071A", "CHECK THAT COMPONENTS OF ACCESS IN PARAMETERS " & + "MAY BE USED IN ASSIGNMENT CONTEXTS"); + + -------------------------------------------------- + + DECLARE -- (A) + + TYPE PTRINT IS ACCESS INTEGER; + PI : PTRINT; + + TASK TA IS + ENTRY EA (PI : IN PTRINT); + END TA; + + TASK BODY TA IS + BEGIN + ACCEPT EA (PI : IN PTRINT) DO + DECLARE + TASK TA1 IS + ENTRY EA1 (I : OUT INTEGER); + ENTRY EA2 (I : IN OUT INTEGER); + END TA1; + + TASK BODY TA1 IS + BEGIN + ACCEPT EA1 (I : OUT INTEGER) DO + I := 7; + END EA1; + + ACCEPT EA2 (I : IN OUT INTEGER) DO + I := I + 1; + END EA2; + END TA1; + + BEGIN + TA1.EA1 (PI.ALL); + TA1.EA2 (PI.ALL); + PI.ALL := PI.ALL + 1; + IF (PI.ALL /= 9) THEN + FAILED ("ASSIGNMENT TO COMPONENT OF " & + "INTEGER ACCESS PARAMETER " & + "FAILED"); + END IF; + END; + END EA; + END TA; + + BEGIN -- (A) + + PI := NEW INTEGER'(0); + TA.EA (PI); + + END; -- (A) + + --------------------------------------------- + + DECLARE -- (B) + + TYPE TBL IS ARRAY (1..3) OF INTEGER; + TYPE PTRTBL IS ACCESS TBL; + PT : PTRTBL; + + TASK TB IS + ENTRY EB (PT : IN PTRTBL); + END TB; + + TASK BODY TB IS + BEGIN + ACCEPT EB (PT : IN PTRTBL) DO + DECLARE + TASK TB1 IS + ENTRY EB1 (T : OUT TBL); + ENTRY EB2 (T : IN OUT TBL); + ENTRY EB3 (I : OUT INTEGER); + ENTRY EB4 (I : IN OUT INTEGER); + END TB1; + + TASK BODY TB1 IS + BEGIN + ACCEPT EB1 (T : OUT TBL) DO + T := (1,2,3); + END EB1; + + ACCEPT EB2 (T : IN OUT TBL) DO + T(3) := T(3) - 1; + END EB2; + + ACCEPT EB3 (I : OUT INTEGER) DO + I := 7; + END EB3; + + ACCEPT EB4 (I : IN OUT INTEGER) DO + I := I + 1; + END EB4; + END TB1; + + BEGIN + TB1.EB1 (PT.ALL); -- (1,2,3) + TB1.EB2 (PT.ALL); -- (1,2,2) + TB1.EB3 (PT(2)); -- (1,7,2) + TB1.EB4 (PT(1)); -- (2,7,2) + PT(3) := PT(3) + 7; -- (2,7,9) + IF (PT.ALL /= (2,7,9)) THEN + FAILED ("ASSIGNMENT TO COMPONENT OF " & + "ARRAY ACCESS PARAMETER FAILED"); + END IF; + END; + END EB; + END TB; + + BEGIN -- (B) + + PT := NEW TBL'(0,0,0); + TB.EB (PT); + + END; -- (B) + + --------------------------------------------- + + DECLARE -- (C) + + TYPE REC IS + RECORD + I1 : INTEGER; + I2 : INTEGER; + I3 : INTEGER; + END RECORD; + + TYPE PTRREC IS ACCESS REC; + PR : PTRREC; + + TASK TC IS + ENTRY EC (PR : IN PTRREC); + END TC; + + TASK BODY TC IS + BEGIN + ACCEPT EC (PR : IN PTRREC) DO + DECLARE + TASK TC1 IS + ENTRY EC1 (R : OUT REC); + ENTRY EC2 (R : IN OUT REC); + ENTRY EC3 (I : OUT INTEGER); + ENTRY EC4 (I : IN OUT INTEGER); + END TC1; + + TASK BODY TC1 IS + BEGIN + ACCEPT EC1 (R : OUT REC) DO + R := (1,2,3); + END EC1; + + ACCEPT EC2 (R : IN OUT REC) DO + R.I3 := R.I3 - 1; + END EC2; + + ACCEPT EC3 (I : OUT INTEGER) DO + I := 7; + END EC3; + + ACCEPT EC4 (I : IN OUT INTEGER) DO + I := I + 1; + END EC4; + END TC1; + + BEGIN + TC1.EC1 (PR.ALL); -- (1,2,3) + TC1.EC2 (PR.ALL); -- (1,2,2) + TC1.EC3 (PR.I2); -- (1,7,2) + TC1.EC4 (PR.I1); -- (2,7,2) + PR.I3 := PR.I3 + 7; -- (2,7,9) + IF (PR.ALL /= (2,7,9)) THEN + FAILED ("ASSIGNMENT TO COMPONENT OF " & + "RECORD ACCESS PARAMETER " & + "FAILED"); + END IF; + END; + END EC; + END TC; + + BEGIN -- (C) + + PR := NEW REC'(0,0,0); + TC.EC (PR); + + END; -- (C) + + --------------------------------------------- + + RESULT; + +END C95071A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95072a.ada b/gcc/testsuite/ada/acats/tests/c9/c95072a.ada new file mode 100644 index 000000000..261007b27 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95072a.ada @@ -0,0 +1,197 @@ +-- C95072A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT SCALAR AND ACCESS PARAMETERS ARE COPIED FOR ALL THREE +-- PARAMETER MODES. +-- SUBTESTS ARE: +-- (A) SCALAR PARAMETERS TO ENTRIES. +-- (B) ACCESS PARAMETERS TO ENTRIES. + +-- JWC 7/22/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95072A IS + +BEGIN + TEST ("C95072A", "CHECK THAT SCALAR AND ACCESS PARAMETERS ARE " & + "COPIED"); + + -------------------------------------------------- + + DECLARE -- (A) + + I : INTEGER; + E : EXCEPTION; + + TASK TA IS + ENTRY EA (EI : IN INTEGER; EO : OUT INTEGER; + EIO : IN OUT INTEGER); + END TA; + + TASK BODY TA IS + + TMP : INTEGER; + + BEGIN + + ACCEPT EA (EI : IN INTEGER; EO : OUT INTEGER; + EIO : IN OUT INTEGER) DO + + TMP := EI; -- SAVE VALUE OF EI AT ACCEPT. + + EO := 10; + IF EI /= TMP THEN + FAILED ("ASSIGNMENT TO SCALAR OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + TMP := EI; -- RESET TMP FOR NEXT CASE. + END IF; + + EIO := EIO + 100; + IF EI /= TMP THEN + FAILED ("ASSIGNMENT TO SCALAR IN OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + TMP := EI; -- RESET TMP FOR NEXT CASE. + END IF; + + I := I + 1; + IF EI /= TMP THEN + FAILED ("ASSIGNMENT TO SCALAR ACTUAL " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + END IF; + + RAISE E; -- CHECK EXCEPTION HANDLING. + END EA; + + EXCEPTION + WHEN OTHERS => NULL; + END TA; + + BEGIN -- (A) + + I := 0; -- INITIALIZE I SO VARIOUS CASES CAN BE DETECTED. + TA.EA (I, I, I); + FAILED ("EXCEPTION NOT RAISED - A"); + + EXCEPTION + WHEN E => + IF I /= 1 THEN + CASE I IS + WHEN 11 => + FAILED ("OUT ACTUAL SCALAR PARAMETER " & + "CHANGED GLOBAL VALUE"); + WHEN 101 => + FAILED ("IN OUT ACTUAL SCALAR " & + "PARAMETER CHANGED GLOBAL VALUE"); + WHEN 111 => + FAILED ("OUT AND IN OUT ACTUAL SCALAR " & + "PARAMETERS CHANGED GLOBAL " & + "VALUE"); + WHEN OTHERS => + FAILED ("UNDETERMINED CHANGE TO GLOBAL " & + "VALUE"); + END CASE; + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - A"); + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + TYPE ACCTYPE IS ACCESS INTEGER; + + I : ACCTYPE; + E : EXCEPTION; + + TASK TB IS + ENTRY EB (EI : IN ACCTYPE; EO : OUT ACCTYPE; + EIO : IN OUT ACCTYPE); + END TB; + + TASK BODY TB IS + + TMP : ACCTYPE; + + BEGIN + + ACCEPT EB (EI : IN ACCTYPE; EO : OUT ACCTYPE; + EIO : IN OUT ACCTYPE) DO + + TMP := EI; -- SAVE VALUE OF EI AT ACCEPT. + + I := NEW INTEGER'(101); + IF EI /= TMP THEN + FAILED ("ASSIGNMENT TO ACCESS ACTUAL " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + TMP := EI; -- RESET TMP FOR NEXT CASE. + END IF; + + EO := NEW INTEGER'(1); + IF EI /= TMP THEN + FAILED ("ASSIGNMENT TO ACCESS OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + TMP := EI; -- RESET TMP FOR NEXT CASE. + END IF; + + EIO := NEW INTEGER'(10); + IF EI /= TMP THEN + FAILED ("ASSIGNMENT TO ACCESS IN OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + END IF; + + RAISE E; -- CHECK EXCEPTION HANDLING. + END EB; + + EXCEPTION + WHEN OTHERS => NULL; + END TB; + + BEGIN -- (B) + + I := NEW INTEGER'(100); + TB.EB (I, I, I); + FAILED ("EXCEPTION NOT RAISED - B"); + + EXCEPTION + WHEN E => + IF I.ALL /= 101 THEN + FAILED ("OUT OR IN OUT ACTUAL ENTRY " & + "PARAMETER VALUE CHANGED DESPITE " & + "RAISED EXCEPTION"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - B"); + END; -- (B) + + -------------------------------------------------- + + RESULT; +END C95072A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95072b.ada b/gcc/testsuite/ada/acats/tests/c9/c95072b.ada new file mode 100644 index 000000000..ba1b91ed1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95072b.ada @@ -0,0 +1,278 @@ +-- C95072B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT PRIVATE TYPES IMPLEMENTED AS SCALAR OR ACCESS TYPES ARE +-- PASSED BY COPY FOR ALL MODES. +-- SUBTESTS ARE: +-- (A) PRIVATE SCALAR PARAMETERS TO ENTRIES. +-- (B) PRIVATE ACCESS PARAMETERS TO ENTRIES. + +-- JWC 7/22/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95072B IS + +BEGIN + TEST("C95072B", "CHECK THAT PRIVATE SCALAR AND ACCESS " & + "PARAMETERS ARE COPIED"); + + --------------------------------------------------- + + DECLARE -- (A) + + PACKAGE SCALAR_PKG IS + + TYPE T IS PRIVATE; + C0 : CONSTANT T; + C1 : CONSTANT T; + C10 : CONSTANT T; + C100 : CONSTANT T; + + FUNCTION "+" (OLD : IN T; INCREMENT : IN T) RETURN T; + FUNCTION CONVERT (OLD_PRIVATE : IN T) RETURN INTEGER; + + PRIVATE + + TYPE T IS NEW INTEGER; + C0 : CONSTANT T := 0; + C1 : CONSTANT T := 1; + C10 : CONSTANT T := 10; + C100 : CONSTANT T := 100; + + END SCALAR_PKG; + + PACKAGE BODY SCALAR_PKG IS + + FUNCTION "+" (OLD : IN T; INCREMENT : IN T) RETURN T IS + BEGIN + RETURN T (INTEGER(OLD) + INTEGER(INCREMENT)); + END "+"; + + FUNCTION CONVERT (OLD_PRIVATE : IN T) RETURN INTEGER IS + BEGIN + RETURN INTEGER (OLD_PRIVATE); + END CONVERT; + + END SCALAR_PKG; + + USE SCALAR_PKG; + + BEGIN -- (A) + + DECLARE -- (A1) + + I : T; + E : EXCEPTION; + + TASK TA IS + ENTRY EA (EI : IN T; EO : OUT T; + EIO : IN OUT T); + END TA; + + TASK BODY TA IS + + TEMP : T; + + BEGIN + + ACCEPT EA (EI : IN T; EO : OUT T; + EIO : IN OUT T) DO + + TEMP := EI; -- SAVE VALUE OF EI AT ACCEPT. + + EO := C10; + IF EI /= TEMP THEN + FAILED ("ASSIGNMENT TO PRIVATE " & + "(SCALAR) OUT PARAMETER " & + "CHANGES THE VALUE OF INPUT " & + "PARAMETER"); + TEMP := EI; -- RESET TEMP FOR NEXT CASE. + END IF; + + EIO := EIO + C100; + IF EI /= TEMP THEN + FAILED ("ASSIGNMENT TO PRIVATE " & + "(SCALAR) IN OUT PARAMETER " & + "CHANGES THE VALUE OF INPUT " & + "PARAMETER"); + TEMP := EI; -- RESET TEMP FOR NEXT CASE. + END IF; + + I := I + C1; + IF EI /= TEMP THEN + FAILED ("ASSIGNMENT TO PRIVATE " & + "(SCALAR) ACTUAL PARAMETER " & + "CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + END IF; + + RAISE E; -- CHECK EXCEPTION + -- HANDLING. + END EA; + + EXCEPTION + WHEN OTHERS => NULL; + END TA; + + BEGIN -- (A1) + + I := C0; -- INITIALIZE I SO VARIOUS CASES CAN BE + -- DETECTED. + TA.EA (I, I, I); + FAILED ("EXCEPTION NOT RAISED - A"); + + EXCEPTION + WHEN E => + IF I /= C1 THEN + CASE CONVERT (I) IS + WHEN 11 => + FAILED ("OUT ACTUAL PRIVATE " & + "(SCALAR) PARAMETER " & + "CHANGED GLOBAL VALUE"); + WHEN 101 => + FAILED ("IN OUT ACTUAL PRIVATE " & + "(SCALAR) PARAMETER " & + "CHANGED GLOBAL VALUE"); + WHEN 111 => + FAILED ("OUT AND IN OUT ACTUAL " & + "PRIVATE (SCALAR) " & + "PARAMETER CHANGED " & + "GLOBAL VALUE"); + WHEN OTHERS => + FAILED ("UNDETERMINED CHANGE TO " & + "GLOBAL VALUE"); + END CASE; + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - A"); + END; -- (A1) + + END; -- (A) + + --------------------------------------------------- + + DECLARE -- (B) + + PACKAGE ACCESS_PKG IS + + TYPE T IS PRIVATE; + C_NULL : CONSTANT T; + C1 : CONSTANT T; + C10 : CONSTANT T; + C100 : CONSTANT T; + C101 : CONSTANT T; + + PRIVATE + + TYPE T IS ACCESS INTEGER; + C_NULL : CONSTANT T := NULL; + C1 : CONSTANT T := NEW INTEGER'(1); + C10 : CONSTANT T := NEW INTEGER'(10); + C100 : CONSTANT T := NEW INTEGER'(100); + C101 : CONSTANT T := NEW INTEGER'(101); + + END ACCESS_PKG; + + USE ACCESS_PKG; + + BEGIN -- (B) + + DECLARE -- (B1) + + I : T; + E : EXCEPTION; + + TASK TB IS + ENTRY EB (EI : IN T; EO : OUT T; + EIO : IN OUT T); + END TB; + + TASK BODY TB IS + + TEMP : T; + + BEGIN + + ACCEPT EB (EI : IN T; EO : OUT T; + EIO : IN OUT T) DO + + TEMP := EI; -- SAVE VALUE OF EI AT ACCEPT. + + I := C101; + IF EI /= TEMP THEN + FAILED ("ASSIGNMENT TO PRIVATE " & + "(ACCESS) ACTUAL VARIABLE " & + "CHANGES THE VALUE OF INPUT " & + "PARAMETER"); + TEMP := EI; -- RESET TEMP FOR NEXT CASE. + END IF; + + EO := C1; + IF EI /= TEMP THEN + FAILED ("ASSIGNMENT TO PRIVATE " & + "(ACCESS) OUT PARAMETER " & + "CHANGES THE VALUE OF INPUT " & + "PARAMETER"); + TEMP := EI; -- RESET TEMP FOR NEXT CASE. + END IF; + + EIO := C10; + IF EI /= TEMP THEN + FAILED ("ASSIGNMENT TO PRIVATE " & + "(ACCESS) IN OUT PARAMETER " & + "CHANGES THE VALUE OF INPUT " & + "PARAMETER"); + END IF; + + RAISE E; -- CHECK EXCEPTION + -- HANDLING. + END EB; + + EXCEPTION + WHEN OTHERS => NULL; + END TB; + + BEGIN -- (B1) + + I := C100; + TB.EB (I, I, I); + FAILED ("EXCEPTION NOT RAISED - B"); + + EXCEPTION + WHEN E => + IF I /= C101 THEN + FAILED ("OUT OR IN OUT ACTUAL ENTRY " & + "PARAMETER VALUE CHANGED DESPITE " & + "RAISED EXCEPTION"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - B"); + END; -- (B1) + + END; -- (B) + + --------------------------------------------------- + + RESULT; +END C95072B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95073a.ada b/gcc/testsuite/ada/acats/tests/c9/c95073a.ada new file mode 100644 index 000000000..f8b1e0daf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95073a.ada @@ -0,0 +1,66 @@ +-- C95073A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT ALIASING IS PERMITTED FOR PARAMETERS OF COMPOSITE TYPES, +-- E.G., THAT A MATRIX ADDITION PROCEDURE CAN BE CALLED WITH THREE +-- IDENTICAL ARGUMENTS. + +-- JWC 7/29/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95073A IS + + TYPE MATRIX IS ARRAY (1..3, 1..3) OF INTEGER; + + A : MATRIX := ((1,2,3), (4,5,6), (7,8,9)); + + TASK T IS + ENTRY MAT_ADD (X,Y : IN MATRIX; SUM : OUT MATRIX); + END T; + + TASK BODY T IS + BEGIN + ACCEPT MAT_ADD (X,Y : IN MATRIX; SUM : OUT MATRIX) DO + FOR I IN 1..3 LOOP + FOR J IN 1..3 LOOP + SUM (I,J) := X (I,J) + Y (I,J); + END LOOP; + END LOOP; + END MAT_ADD; + END T; + +BEGIN + + TEST ("C95073A", "CHECK THAT ALIASING IS PERMITTED FOR " & + "PARAMETERS OF COMPOSITE TYPES"); + + T.MAT_ADD (A, A, A); + + IF A /= ((2,4,6), (8,10,12), (14,16,18)) THEN + FAILED ("THE RESULT OF THE MATRIX ADDITION IS INCORRECT"); + END IF; + + RESULT; + +END C95073A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95074c.ada b/gcc/testsuite/ada/acats/tests/c9/c95074c.ada new file mode 100644 index 000000000..872a5928d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95074c.ada @@ -0,0 +1,103 @@ +-- C95074C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT 'FIRST, 'LAST, 'LENGTH, AND 'RANGE, CAN BE APPLIED TO AN +-- OUT PARAMETER OR OUT PARAMETER SUBCOMPONENT THAT DOES NOT HAVE AN +-- ACCESS TYPE. + +-- JWC 6/25/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95074C IS + +BEGIN + + TEST ("C95074C", "CHECK THAT ATTRIBUTES MAY BE APPLIED TO " & + "NON-ACCESS FORMAL OUT PARAMETERS"); + + DECLARE + + TYPE ARR IS ARRAY (1 .. 10) OF NATURAL; + + TYPE REC IS RECORD + A : ARR; + END RECORD; + + A1 : ARR; + R1 : REC; + + TASK T1 IS + ENTRY E (A2 : OUT ARR; R2 : OUT REC); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E (A2 : OUT ARR; R2 : OUT REC) DO + + IF A2'FIRST /= 1 THEN + FAILED ("WRONG VALUE FOR A2'FIRST"); + END IF; + + IF A2'LAST /= 10 THEN + FAILED ("WRONG VALUE FOR A2'LAST"); + END IF; + + IF A2'LENGTH /= 10 THEN + FAILED ("WRONG VALUE FOR A2'LENGTH"); + END IF; + + IF (1 NOT IN A2'RANGE) OR + (10 NOT IN A2'RANGE) OR + (0 IN A2'RANGE) OR + (11 IN A2'RANGE) THEN + FAILED ("WRONG VALUE FOR A2'RANGE"); + END IF; + + IF R2.A'FIRST /= 1 THEN + FAILED ("WRONG VALUE FOR R2.A'FIRST"); + END IF; + + IF R2.A'LAST /= 10 THEN + FAILED ("WRONG VALUE FOR R2.A'LAST"); + END IF; + + IF R2.A'LENGTH /= 10 THEN + FAILED ("WRONG VALUE FOR R2.A'LENGTH"); + END IF; + + IF (1 NOT IN R2.A'RANGE) OR + (10 NOT IN R2.A'RANGE) OR + (0 IN R2.A'RANGE) OR + (11 IN R2.A'RANGE) THEN + FAILED ("WRONG VALUE FOR R2.A'RANGE"); + END IF; + END E; + END T1; + + BEGIN + T1.E (A1,R1); + END; + + RESULT; +END C95074C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95076a.ada b/gcc/testsuite/ada/acats/tests/c9/c95076a.ada new file mode 100644 index 000000000..ba00cee68 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95076a.ada @@ -0,0 +1,85 @@ +-- C95076A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT AN ACCEPT STATEMENT WITH AND WITHOUT A RETURN +-- STATEMENT RETURNS CORRECTLY. + +-- GLH 7/11/85 + +WITH REPORT; USE REPORT; + +PROCEDURE C95076A IS + + I : INTEGER; + + TASK T1 IS + ENTRY E1 (N : IN OUT INTEGER); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (N : IN OUT INTEGER) DO + IF (N = 5) THEN + N := N + 5; + ELSE + N := 0; + END IF; + END E1; + END T1; + + TASK T2 IS + ENTRY E2 (N : IN OUT INTEGER); + END T2; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (N : IN OUT INTEGER) DO + IF (N = 10) THEN + N := N + 5; + RETURN; + END IF; + N := 0; + END E2; + END T2; + +BEGIN + + TEST ("C95076A", "CHECK THAT AN ACCEPT STATEMENT WITH AND " & + "WITHOUT A RETURN STATEMENT RETURNS CORRECTLY"); + + I := 5; + T1.E1 (I); + IF (I /= 10) THEN + FAILED ("INCORRECT RENDEVOUS WITHOUT A RETURN"); + END IF; + + I := 10; + T2.E2 (I); + IF (I /= 15) THEN + FAILED ("INCORRECT RENDEVOUS WITH A RETURN"); + END IF; + + RESULT; + +END C95076A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95078a.ada b/gcc/testsuite/ada/acats/tests/c9/c95078a.ada new file mode 100644 index 000000000..399be9602 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95078a.ada @@ -0,0 +1,195 @@ +-- C95078A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT AN EXCEPTION RAISED DURING THE EXECUTION OF AN ACCEPT +-- STATEMENT CAN BE HANDLED WITHIN THE ACCEPT BODY. + +-- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X +-- *** remove incompatibilities associated with the transition -- 9X +-- *** to Ada 9X. -- 9X +-- *** -- 9X + +-- HISTORY: +-- DHH 03/21/88 CREATED ORIGINAL TEST. +-- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + +WITH REPORT; USE REPORT; +PROCEDURE C95078A IS + +BEGIN + + TEST("C95078A", "CHECK THAT AN EXCEPTION RAISED DURING THE " & + "EXECUTION OF AN ACCEPT STATEMENT CAN BE " & + "HANDLED WITHIN THE ACCEPT BODY"); + + DECLARE + O,PT,QT,R,S,TP,B,C,D :INTEGER := 0; + TASK TYPE PROG_ERR IS + ENTRY START(M,N,A : IN OUT INTEGER); + ENTRY STOP; + END PROG_ERR; + + TASK T IS + ENTRY START(M,N,A : IN OUT INTEGER); + ENTRY STOP; + END T; + + TYPE REC IS + RECORD + B : PROG_ERR; + END RECORD; + + TYPE ACC IS ACCESS PROG_ERR; + + SUBTYPE X IS INTEGER RANGE 1 .. 10; + + PACKAGE P IS + OBJ : REC; + END P; + + TASK BODY PROG_ERR IS + FAULT : X; + BEGIN + ACCEPT START(M,N,A : IN OUT INTEGER) DO + BEGIN + M := IDENT_INT(1); + FAULT := IDENT_INT(11); + FAULT := IDENT_INT(FAULT); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED ERROR RAISED - " & + "CONSTRAINT - TASK TYPE"); + END; -- EXCEPTION + BEGIN + N := IDENT_INT(1); + FAULT := IDENT_INT(5); + FAULT := FAULT/IDENT_INT(0); + FAULT := IDENT_INT(FAULT); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED ERROR RAISED - " & + "CONSTRAINT - TASK TYPE"); + END; -- EXCEPTION + A := IDENT_INT(1); + END START; + + ACCEPT STOP; + END PROG_ERR; + + TASK BODY T IS + FAULT : X; + BEGIN + ACCEPT START(M,N,A : IN OUT INTEGER) DO + BEGIN + M := IDENT_INT(1); + FAULT := IDENT_INT(11); + FAULT := IDENT_INT(FAULT); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED ERROR RAISED - " & + "CONSTRAINT - TASK"); + END; -- EXCEPTION + BEGIN + N := IDENT_INT(1); + FAULT := IDENT_INT(5); + FAULT := FAULT/IDENT_INT(0); + FAULT := IDENT_INT(FAULT); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED ERROR RAISED - " & + "CONSTRAINT - TASK"); + END; -- EXCEPTION + A := IDENT_INT(1); + END START; + + ACCEPT STOP; + END T; + + PACKAGE BODY P IS + BEGIN + OBJ.B.START(O,PT,B); + OBJ.B.STOP; + + IF O /= IDENT_INT(1) OR PT /= IDENT_INT(1) THEN + FAILED("EXCEPTION HANDLER NEVER ENTERED " & + "PROPERLY - TASK TYPE OBJECT"); + END IF; + + IF B /= IDENT_INT(1) THEN + FAILED("TASK NOT EXITED PROPERLY - TASK TYPE " & + "OBJECT"); + END IF; + END P; + + PACKAGE Q IS + OBJ : ACC; + END Q; + + PACKAGE BODY Q IS + BEGIN + OBJ := NEW PROG_ERR; + OBJ.START(QT,R,C); + OBJ.STOP; + + IF QT /= IDENT_INT(1) OR R /= IDENT_INT(1) THEN + FAILED("EXCEPTION HANDLER NEVER ENTERED " & + "PROPERLY - ACCESS TASK TYPE"); + END IF; + + IF C /= IDENT_INT(1) THEN + FAILED("TASK NOT EXITED PROPERLY - ACCESS TASK " & + "TYPE"); + END IF; + END; + + BEGIN + T.START(S,TP,D); + T.STOP; + + IF S /= IDENT_INT(1) OR TP /= IDENT_INT(1) THEN + FAILED("EXCEPTION HANDLER NEVER ENTERED PROPERLY " & + "- TASK"); + END IF; + + IF D /= IDENT_INT(1) THEN + FAILED("TASK NOT EXITED PROPERLY - TASK"); + END IF; + END; -- DECLARE + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION NOT HANDLED INSIDE ACCEPT BODY"); + RESULT; +END C95078A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95080b.ada b/gcc/testsuite/ada/acats/tests/c9/c95080b.ada new file mode 100644 index 000000000..1c3c3b8b0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95080b.ada @@ -0,0 +1,71 @@ +-- C95080B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT PARAMETERLESS ENTRIES CAN BE CALLED WITH THE APPROPRIATE +-- NOTATION. + +-- JWC 7/15/85 +-- JRK 8/21/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95080B IS + + I : INTEGER := 1; + + TASK T IS + ENTRY E; + ENTRY EF (1..3); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E DO + I := 15; + END E; + ACCEPT EF (2) DO + I := 20; + END EF; + END T; + +BEGIN + + TEST ("C95080B", "CHECK THAT PARAMETERLESS ENTRIES CAN BE " & + "CALLED"); + + T.E; + IF I /= 15 THEN + FAILED ("PARAMETERLESS ENTRY CALL YIELDS INCORRECT " & + "RESULT"); + END IF; + + I := 0; + T.EF (2); + IF I /= 20 THEN + FAILED ("PARAMETERLESS ENTRY FAMILY CALL YIELDS " & + "INCORRECT RESULT"); + END IF; + + RESULT; + +END C95080B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95082g.ada b/gcc/testsuite/ada/acats/tests/c9/c95082g.ada new file mode 100644 index 000000000..f02e35db0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95082g.ada @@ -0,0 +1,91 @@ +-- C95082G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT FOR CALLS TO ENTRIES HAVING AT LEAST ONE DEFAULT +-- PARAMETER, THE CORRECT ASSOCIATION IS MADE BETWEEN ACTUAL AND +-- FORMAL PARAMETERS. + +-- JWC 7/17/85 + +WITH REPORT;USE REPORT; +PROCEDURE C95082G IS + + Y1,Y2,Y3 : INTEGER := 0; + + TASK T IS + ENTRY E (I1: INTEGER; I2: INTEGER := 2; I3: INTEGER := 3; + O1,O2,O3: OUT INTEGER); + END T; + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E (I1: INTEGER; I2: INTEGER := 2; + I3: INTEGER := 3; + O1,O2,O3: OUT INTEGER) DO + O1 := I1; + O2 := I2; + O3 := I3; + END E; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + + +BEGIN + + TEST ("C95082G", "CHECK ASSOCIATIONS BETWEEN ACTUAL AND FORMAL " & + "PARAMETERS (HAVING DEFAULT VALUES)"); + + T.E (I1=>11, I2=>12, I3=>13, O1=>Y1, O2=>Y2, O3=>Y3); + IF (Y1 /= 11) OR (Y2 /= 12) OR (Y3 /= 13) THEN + FAILED ("INCORRECT PARAMETER ASSOCIATION - 1"); + END IF; + + T.E (I1=>21, O1=>Y1, O2=>Y2, O3=>Y3); + IF (Y1 /= 21) OR (Y2 /= 2) OR (Y3 /= 3) THEN + FAILED ("INCORRECT PARAMETER ASSOCIATION - 2"); + END IF; + + T.E (O1=>Y1, O3=>Y3, I1=>31, I3=>33, O2=>Y2); + IF (Y1 /= 31) OR (Y2 /= 2) OR (Y3 /= 33) THEN + FAILED ("INCORRECT PARAMETER ASSOCIATION - 3"); + END IF; + + T.E (41, 42, O1=>Y1, O2=>Y2, O3=>Y3); + IF (Y1 /= 41) OR (Y2 /= 42) OR (Y3 /= 3) THEN + FAILED ("INCORRECT PARAMETER ASSOCIATION - 4"); + END IF; + + T.E (51, O3=>Y3, O1=>Y1, O2=>Y2, I3=>53); + IF (Y1 /= 51) OR (Y2 /= 2) OR (Y3 /= 53) THEN + FAILED ("INCORRECT PARAMETER ASSOCIATION - 5"); + END IF; + + RESULT; + +END C95082G; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085a.ada b/gcc/testsuite/ada/acats/tests/c9/c95085a.ada new file mode 100644 index 000000000..fc7e0dc9e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085a.ada @@ -0,0 +1,279 @@ +-- C95085A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR OUT OF RANGE SCALAR +-- ARGUMENTS. SUBTESTS ARE: +-- (A) STATIC IN ARGUMENT. +-- (B) DYNAMIC IN ARGUMENT. +-- (C) IN OUT, OUT OF RANGE ON CALL. +-- (D) OUT, OUT OF RANGE ON RETURN. +-- (E) IN OUT, OUT OF RANGE ON RETURN. + +-- GLH 7/15/85 +-- JRK 8/23/85 +-- JWC 11/15/85 ADDED VARIABLE "CALLED" TO ENSURE THAT THE ENTRY +-- CALL WAS MADE FOR THOSE CASES THAT ARE APPLICABLE. + +WITH REPORT; USE REPORT; +PROCEDURE C95085A IS + + SUBTYPE DIGIT IS INTEGER RANGE 0..9; + + D : DIGIT; + I : INTEGER; + M1 : CONSTANT INTEGER := IDENT_INT (-1); + COUNT : INTEGER := 0; + CALLED : BOOLEAN; + + SUBTYPE SI IS INTEGER RANGE M1 .. 10; + + TASK T1 IS + ENTRY E1 (PIN : IN DIGIT; WHO : STRING); -- (A), (B). + END T1; + + TASK BODY T1 IS + BEGIN + LOOP + BEGIN + SELECT + ACCEPT E1 (PIN : IN DIGIT; + WHO : STRING) DO -- (A), (B). + FAILED ("EXCEPTION NOT RAISED BEFORE " & + "CALL - E1 " & WHO); + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN E1"); + END; + END LOOP; + END T1; + + TASK T2 IS + ENTRY E2 (PINOUT : IN OUT DIGIT; WHO : STRING); -- (C). + END T2; + + TASK BODY T2 IS + BEGIN + LOOP + BEGIN + SELECT + ACCEPT E2 (PINOUT : IN OUT DIGIT; + WHO : STRING) DO -- (C). + FAILED ("EXCEPTION NOT RAISED BEFORE " & + "CALL - E2 " & WHO); + END E2; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN E2"); + END; + END LOOP; + END T2; + + TASK T3 IS + ENTRY E3 (POUT : OUT SI; WHO : STRING); -- (D). + END T3; + + TASK BODY T3 IS + BEGIN + LOOP + BEGIN + SELECT + ACCEPT E3 (POUT : OUT SI; + WHO : STRING) DO -- (D). + CALLED := TRUE; + IF WHO = "10" THEN + POUT := IDENT_INT (10); -- 10 IS NOT + -- A DIGIT. + ELSE + POUT := -1; + END IF; + END E3; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN E3"); + END; + END LOOP; + END T3; + + TASK T4 IS + ENTRY E4 (PINOUT : IN OUT INTEGER; WHO : STRING); -- (E). + END T4; + + TASK BODY T4 IS + BEGIN + LOOP + BEGIN + SELECT + ACCEPT E4 (PINOUT : IN OUT INTEGER; + WHO : STRING) DO -- (E). + CALLED := TRUE; + IF WHO = "10" THEN + PINOUT := 10; -- 10 IS NOT A DIGIT. + ELSE + PINOUT := IDENT_INT (-1); + END IF; + END E4; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN E4"); + END; + END LOOP; + END T4; + +BEGIN + + TEST ("C95085A", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "FOR OUT OF RANGE SCALAR ARGUMENTS"); + + BEGIN -- (A) + T1.E1 (10, "10"); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR E1 (10)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E1 (10)"); + END; -- (A) + + BEGIN -- (B) + T1.E1 (IDENT_INT (-1), "-1"); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR E1 (" & + "IDENT_INT (-1))"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E1 (" & + "IDENT_INT (-1))"); + END; -- (B) + + BEGIN -- (C) + I := IDENT_INT (10); + T2.E2 (I, "10"); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR E2 (10)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E2 (10)"); + END; -- (C) + + BEGIN -- (C1) + I := IDENT_INT (-1); + T2.E2 (I, "-1"); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR E2 (-1)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E2 (-1)"); + END; -- (C1) + + BEGIN -- (D) + CALLED := FALSE; + D := IDENT_INT (1); + T3.E3 (D, "10"); + FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM " & + "E3 (10)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "E3 (10)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E3 (10)"); + END; -- (D) + + BEGIN -- (D1) + CALLED := FALSE; + D := IDENT_INT (1); + T3.E3 (D, "-1"); + FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM " & + "E3 (-1)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "E3 (-1)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E3 (-1)"); + END; -- (D1) + + BEGIN -- (E) + CALLED := FALSE; + D := 9; + T4.E4 (D, "10"); + FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM " & + "E4 (10)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "E4 (10)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E4 (10)"); + END; -- (E) + + BEGIN -- (E1) + CALLED := FALSE; + D := 0; + T4.E4 (D, "-1"); + FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM " & + "E4 (-1)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "E4 (-1)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E4 (-1)"); + END; -- (E1) + + IF COUNT /= 8 THEN + FAILED ("INCORRECT NUMBER OF CONSTRAINT_ERRORS RAISED"); + END IF; + + RESULT; + +END C95085A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085b.ada b/gcc/testsuite/ada/acats/tests/c9/c95085b.ada new file mode 100644 index 000000000..27ef17052 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085b.ada @@ -0,0 +1,183 @@ +-- C95085B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER APPROPRIATE CIRCUMSTANCES +-- WITH RESPECT TO PARAMETERS OF RECORD TYPES IN ENTRY CALLS. SUBTESTS +-- INVOLVE ACTUAL RECORD PARAMETERS WHOSE CONSTRAINT VALUES ARE NOT +-- EQUAL TO THE CONSTRAINTS ON THEIR CORRESPONDING FORMAL PARAMETERS: +-- (A) IN PARAMETER, STATIC AGGREGATE. +-- (B) IN PARAMETER, DYNAMIC AGGREGATE. +-- (C) IN PARAMETER, VARIABLE. +-- (D) IN OUT PARAMETER, EXCEPTION RAISED ON CALL. +-- (E) OUT PARAMETER, EXCEPTION RAISED ON CALL. + +-- JWC 10/25/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95085B IS + + SUBTYPE INT IS INTEGER RANGE 0..10; + + TYPE REC (N : INT := 0) IS + RECORD + A : STRING (1..N); + END RECORD; + + SUBTYPE SREC IS REC(N=>3); + +BEGIN + + TEST ("C95085B", "CHECK RAISING OF CONSTRAINT_ERROR FOR " & + "PARAMETERS OF RECORD TYPES"); + + DECLARE + + TASK TSK1 IS + ENTRY E (R : IN SREC); + END TSK1; + + TASK BODY TSK1 IS + BEGIN + LOOP + BEGIN + SELECT + ACCEPT E (R : IN SREC) DO + FAILED ("EXCEPTION NOT RAISED ON " & + "CALL TO TSK1"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TSK1"); + END; + END LOOP; + END TSK1; + + BEGIN + + BEGIN -- (A) + TSK1.E ((2,"AA")); + FAILED ("EXCEPTION NOT RAISED IN SUBTEST (A)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (A)"); + END; -- (A) + + BEGIN -- (B) + TSK1.E ((IDENT_INT(2), "AA")); + FAILED ("EXCEPTION NOT RAISED IN SUBTEST (B)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (B)"); + END; -- (B) + + DECLARE -- (C) + R : REC := (IDENT_INT(2), "AA"); + BEGIN -- (C) + TSK1.E (R); + FAILED ("EXCEPTION NOT RAISED IN SUBTEST (C)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (C)"); + END; -- (C) + + END; + + DECLARE -- (D) + + R : REC := (IDENT_INT(2), "AA"); + + TASK TSK2 IS + ENTRY E (R : IN OUT SREC); + END TSK2; + + TASK BODY TSK2 IS + BEGIN + SELECT + ACCEPT E (R : IN OUT SREC) DO + FAILED ("EXCEPTION NOT RAISED ON CALL TO " & + "TSK2"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TSK2"); + END TSK2; + + BEGIN -- (D) + TSK2.E (R); + FAILED ("EXCEPTION NOT RAISED IN SUBTEST (D)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (D)"); + END; -- (D) + + DECLARE -- (E) + + R : REC; + + TASK TSK3 IS + ENTRY E (R : OUT SREC); + END TSK3; + + TASK BODY TSK3 IS + BEGIN + SELECT + ACCEPT E (R : OUT SREC) DO + FAILED ("EXCEPTION NOT RAISED ON CALL TO " & + "TSK3"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TSK3"); + END TSK3; + + BEGIN -- (E) + TSK3.E (R); + FAILED ("EXCEPTION NOT RAISED IN SUBTEST (E)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (E)"); + END; -- (E) + + RESULT; + +END C95085B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085c.ada b/gcc/testsuite/ada/acats/tests/c9/c95085c.ada new file mode 100644 index 000000000..f2875e340 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085c.ada @@ -0,0 +1,245 @@ +-- C95085C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE +-- APPROPRIATE CIRCUMSTANCES FOR ARRAY PARAMETERS IN ENTRY CALLS, +-- NAMELY WHEN THE ACTUAL BOUNDS DON'T MATCH THE FORMAL BOUNDS +-- (BEFORE THE CALL FOR ALL MODES). +-- SUBTESTS ARE: +-- (A) IN MODE, ONE DIMENSION, STATIC AGGREGATE. +-- (B) IN MODE, TWO DIMENSIONS, DYNAMIC AGGREGATE. +-- (C) IN MODE, TWO DIMENSIONS, DYNAMIC VARIABLE. +-- (D) IN OUT MODE, THREE DIMENSIONS, STATIC VARIABLE. +-- (E) OUT MODE, ONE DIMENSION, DYNAMIC VARIABLE. +-- (F) IN OUT MODE, NULL STRING AGGREGATE. +-- (G) IN OUT MODE, TWO DIMENSIONS, NULL AGGREGATE (OK CASE). +-- IN OUT MODE, TWO DIMENSIONS, NULL AGGREGATE. + +-- JWC 10/28/85 +-- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X. + +WITH REPORT; USE REPORT; +PROCEDURE C95085C IS + +BEGIN + TEST ("C95085C", "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "ACTUAL ARRAY BOUNDS DON'T MATCH FORMAL BOUNDS"); + + -------------------------------------------------- + + DECLARE -- (A) + SUBTYPE ST IS STRING (1..3); + + TASK TSK IS + ENTRY E (A : ST); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (A : ST) DO + FAILED ("EXCEPTION NOT RAISED ON CALL - (A)"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (A)"); + END TSK; + + BEGIN -- (A) + + TSK.E ("AB"); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (A)"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (A)"); + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + SUBTYPE S IS INTEGER RANGE 1..3; + TYPE T IS ARRAY (S,S) OF INTEGER; + + TASK TSK IS + ENTRY E (A : T); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (A : T) DO + FAILED ("EXCEPTION NOT RAISED ON CALL - (B)"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (B)"); + END TSK; + + BEGIN -- (B) + + TSK.E ((1..3 => (1..IDENT_INT(2) => 0))); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (B)"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (B)"); + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + SUBTYPE S IS INTEGER RANGE 1..5; + TYPE T IS ARRAY (S RANGE <>, S RANGE <>) OF INTEGER; + SUBTYPE ST IS T (1..3,1..3); + V : T (1..IDENT_INT(2), 1..3) := + (1..IDENT_INT(2) => (1..3 => 0)); + + TASK TSK IS + ENTRY E (A :ST); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (A :ST) DO + FAILED ("EXCEPTION NOT RAISED ON CALL - (C)"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (C)"); + END TSK; + + BEGIN -- (C) + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (C)"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (C)"); + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D) + + SUBTYPE S IS INTEGER RANGE 1..5; + TYPE T IS ARRAY (S RANGE <>, S RANGE <>, S RANGE <>) OF + INTEGER; + SUBTYPE ST IS T (1..3, 1..3, 1..3); + V : T (1..3, 1..2, 1..3) := + (1..3 => (1..2 => (1..3 => 0))); + + TASK TSK IS + ENTRY E (A : IN OUT ST); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (A : IN OUT ST) DO + FAILED ("EXCEPTION NOT RAISED ON CALL - (D)"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (D)"); + END TSK; + + BEGIN -- (D) + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (D)"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (D)"); + END; -- (D) + + -------------------------------------------------- + + + DECLARE -- (G) + + SUBTYPE S IS INTEGER RANGE 1..5; + TYPE T IS ARRAY (S RANGE <>, S RANGE <>) OF CHARACTER; + SUBTYPE ST IS T (2..1, 2..1); + V : T (2..1, 2..1) := (2..1 => (2..1 => ' ')); + + TASK TSK IS + ENTRY E (A : IN OUT ST); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (A : IN OUT ST) DO + COMMENT ("OK CASE CALLED CORRECTLY"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (G)"); + END TSK; + + BEGIN -- (G) + + TSK.E (V); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED ON OK CASE - (G)"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED ON OK CASE - (G)"); + END; -- (G) + + -------------------------------------------------- + + + RESULT; +END C95085C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085d.ada b/gcc/testsuite/ada/acats/tests/c9/c95085d.ada new file mode 100644 index 000000000..059298180 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085d.ada @@ -0,0 +1,97 @@ +-- C95085D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE +-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN +-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL +-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT +-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE +-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + +-- (A) BEFORE CALL, IN MODE, STATIC PRIVATE DISCRIMINANT. + +-- JWC 10/23/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95085D IS + +BEGIN + TEST ("C95085D", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + PACKAGE PKG IS + TYPE E IS (E1, E2, E3); + TYPE T (D : E := E1) IS PRIVATE; + TYPE AR IS ARRAY (E1 .. E3) OF INTEGER; + PRIVATE + TYPE T (D : E := E1) IS + RECORD + I : INTEGER; + A : AR; + END RECORD; + END PKG; + USE PKG; + + TYPE A IS ACCESS T; + SUBTYPE A1 IS A (E3); + V : A (E2) := NEW T (E2); + + TASK TSK IS + ENTRY E (X : A1); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : A1) DO + FAILED ("EXCEPTION NOT RAISED ON CALL"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + ------------------------------------------------ + + RESULT; +END C95085D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085e.ada b/gcc/testsuite/ada/acats/tests/c9/c95085e.ada new file mode 100644 index 000000000..86c446c8b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085e.ada @@ -0,0 +1,87 @@ +-- C95085E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE +-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN +-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL +-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT +-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE +-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + +-- (B) BEFORE CALL, IN MODE, DYNAMIC TWO DIMENSIONAL BOUNDS. + +-- JWC 10/23/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95085E IS + +BEGIN + TEST ("C95085E", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + TYPE T IS ARRAY (BOOLEAN RANGE <>, CHARACTER RANGE <>) OF + INTEGER; + + TYPE A IS ACCESS T; + SUBTYPE A1 IS A (BOOLEAN, 'A'..'C'); + V : A := NEW T (BOOLEAN, 'A'..IDENT_CHAR('B')); + + TASK TSK IS + ENTRY E (X : A1); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : A1) DO + FAILED ("EXCEPTION NOT RAISED ON CALL"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; +END C95085E; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085f.ada b/gcc/testsuite/ada/acats/tests/c9/c95085f.ada new file mode 100644 index 000000000..7a716595d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085f.ada @@ -0,0 +1,84 @@ +-- C95085F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE +-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY +-- WHEN THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL +-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT +-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE +-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + +-- (C) BEFORE CALL, IN OUT MODE, STATIC ONE DIMENSIONAL BOUNDS. + +-- JWC 10/23/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95085F IS + +BEGIN + TEST ("C95085F", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + TYPE A IS ACCESS STRING; + SUBTYPE A1 IS A (1..3); + V : A (2..4) := NEW STRING (2..4); + + TASK TSK IS + ENTRY E (X : IN OUT A1); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : IN OUT A1) DO + FAILED ("EXCEPTION NOT RAISED ON CALL"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; +END C95085F; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085g.ada b/gcc/testsuite/ada/acats/tests/c9/c95085g.ada new file mode 100644 index 000000000..2004164d2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085g.ada @@ -0,0 +1,98 @@ +-- C95085G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE +-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN +-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL +-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT +-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE +-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + +-- (D) BEFORE CALL, IN OUT MODE, DYNAMIC RECORD DISCRIMINANTS. + +-- JWC 10/23/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95085G IS + +BEGIN + TEST ("C95085G", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + SUBTYPE INT IS INTEGER RANGE 0..10; + TYPE T (C : CHARACTER := 'A'; + B : BOOLEAN := FALSE; + I : INT := 0) IS + RECORD + J : INTEGER; + CASE B IS + WHEN FALSE => + K : INTEGER; + WHEN TRUE => + S : STRING (1 .. I); + END CASE; + END RECORD; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A ('Z', TRUE, 5); + V : A := NEW T ('Z', IDENT_BOOL(FALSE), 5); + + TASK TSK IS + ENTRY E (X : IN OUT SA); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : IN OUT SA) DO + FAILED ("EXCEPTION NOT RAISED ON CALL"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; +END C95085G; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085h.ada b/gcc/testsuite/ada/acats/tests/c9/c95085h.ada new file mode 100644 index 000000000..a46720474 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085h.ada @@ -0,0 +1,111 @@ +-- C95085H.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE +-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN +-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL +-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT +-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE +-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + +-- (E) AFTER RETURN, IN OUT MODE, STATIC LIMITED PRIVATE +-- DISCRIMINANTS. + +-- JWC 10/23/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95085H IS + +BEGIN + TEST ("C95085H", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + CALLED : BOOLEAN := FALSE; + + PACKAGE PKG IS + SUBTYPE INT IS INTEGER RANGE 0..10; + SUBTYPE CHAR IS CHARACTER RANGE 'A' .. 'C'; + TYPE T (I : INT := 0; C : CHAR := 'A') IS + LIMITED PRIVATE; + PRIVATE + TYPE T (I : INT := 0; C : CHAR := 'A') IS + RECORD + J : INTEGER; + CASE C IS + WHEN 'A' => + K : INTEGER; + WHEN 'B' => + S : STRING (1..I); + WHEN OTHERS => + NULL; + END CASE; + END RECORD; + END PKG; + USE PKG; + + TYPE A IS ACCESS T; + + V : A (2,'B') := NEW T (2,'B'); + + TASK TSK IS + ENTRY E (X : IN OUT A); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : IN OUT A) DO + CALLED := TRUE; + X := NEW T (2,'A'); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; +END C95085H; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085i.ada b/gcc/testsuite/ada/acats/tests/c9/c95085i.ada new file mode 100644 index 000000000..b2b08543c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085i.ada @@ -0,0 +1,100 @@ +-- C95085I.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE +-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN +-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL +-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT +-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE +-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + +-- (F) AFTER RETURN, IN OUT MODE, DYNAMIC THREE DIMENSIONAL +-- BOUNDS. + +-- JWC 10/23/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95085I IS + +BEGIN + TEST ("C95085I", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + CALLED : BOOLEAN := FALSE; + + TYPE E IS (E1, E2, E3); + + TYPE T IS ARRAY (CHARACTER RANGE <>, + E RANGE <>, + BOOLEAN RANGE <> + ) OF INTEGER; + + TYPE A IS ACCESS T; + + V : A ('A'..'Z', E1..E2, BOOLEAN) := + NEW T ('A'..'Z', E1..E2, BOOLEAN); + + TASK TSK IS + ENTRY E (X : IN OUT A); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : IN OUT A) DO + CALLED := TRUE; + IF EQUAL (3,3) THEN + X := NEW T ('A'..'Z', E2..E3, BOOLEAN); + END IF; + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; +END C95085I; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085j.ada b/gcc/testsuite/ada/acats/tests/c9/c95085j.ada new file mode 100644 index 000000000..d1ea3ce2e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085j.ada @@ -0,0 +1,90 @@ +-- C95085J.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE +-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN +-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL +-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT +-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE +-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + +-- (G) AFTER RETURN, OUT MODE, UNCONSTRAINED FORMAL, STATIC ONE +-- DIMENSIONAL BOUNDS. + +-- JWC 10/23/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95085J IS + +BEGIN + TEST ("C95085J", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + CALLED : BOOLEAN := FALSE; + + TYPE A IS ACCESS STRING; + + V : A (1..3) := NEW STRING (1..3); + + TASK TSK IS + ENTRY E (X : OUT A); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : OUT A) DO + CALLED := TRUE; + X := NEW STRING (2..3); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; +END C95085J; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085k.ada b/gcc/testsuite/ada/acats/tests/c9/c95085k.ada new file mode 100644 index 000000000..37952f0ae --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085k.ada @@ -0,0 +1,97 @@ +-- C95085K.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE +-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN +-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL +-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT +-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE +-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + +-- (H) AFTER RETURN, OUT MODE, UNCONSTRAINED FORMAL, DYNAMIC +-- RECORD DISCRIMINANT. + +-- JWC 10/24/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95085K IS + +BEGIN + TEST ("C95085K", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + CALLED : BOOLEAN := FALSE; + + TYPE ARR IS ARRAY (BOOLEAN RANGE <>) OF INTEGER; + TYPE T (B : BOOLEAN := FALSE) IS + RECORD + I : INTEGER; + A : ARR (FALSE..B); + END RECORD; + + TYPE A IS ACCESS T; + + V : A (IDENT_BOOL(FALSE)) := NEW T (IDENT_BOOL(FALSE)); + + TASK TSK IS + ENTRY E (X : OUT A); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : OUT A) DO + CALLED := TRUE; + X := NEW T (TRUE); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; +END C95085K; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085l.ada b/gcc/testsuite/ada/acats/tests/c9/c95085l.ada new file mode 100644 index 000000000..cb62ff249 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085l.ada @@ -0,0 +1,109 @@ +-- C95085L.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE +-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN +-- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL +-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT +-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE +-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + +-- (I) AFTER RETURN, OUT MODE, CONSTRAINED FORMAL, STATIC +-- PRIVATE DISCRIMINANTS. + +-- JWC 10/24/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95085L IS + +BEGIN + TEST ("C95085L", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + CALLED : BOOLEAN := FALSE; + + PACKAGE PKG IS + TYPE E IS (E1, E2, E3); + TYPE T (D : E := E1; B : BOOLEAN := FALSE) IS + PRIVATE; + PRIVATE + TYPE ARR IS ARRAY (E RANGE <>) OF INTEGER; + TYPE T (D : E := E1; B : BOOLEAN := FALSE) IS + RECORD + I : INTEGER; + CASE B IS + WHEN FALSE => + J : INTEGER; + WHEN TRUE => + A : ARR (E1 .. D); + END CASE; + END RECORD; + END PKG; + USE PKG; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (E2, TRUE); + V : A (E2, FALSE) := NEW T (E2, FALSE); + + TASK TSK IS + ENTRY E (X : OUT SA); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : OUT SA) DO + CALLED := TRUE; + X := NEW T (E2, TRUE); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + ------------------------------------------------ + + RESULT; +END C95085L; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085m.ada b/gcc/testsuite/ada/acats/tests/c9/c95085m.ada new file mode 100644 index 000000000..45e73fffa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085m.ada @@ -0,0 +1,96 @@ +-- C95085M.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE +-- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN THE +-- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL +-- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT +-- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE +-- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + +-- (J) AFTER RETURN, OUT MODE, CONSTRAINED FORMAL, DYNAMIC TWO +-- DIMENSIONAL BOUNDS. + +-- JWC 10/24/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95085M IS + +BEGIN + TEST ("C95085M", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + CALLED : BOOLEAN := FALSE; + + TYPE T IS ARRAY (INTEGER RANGE <>, + CHARACTER RANGE <>) OF INTEGER; + + TYPE A IS ACCESS T; + + V : A (1..10, 'A'..'Z') := NEW T (1..10, 'A'..'Z'); + + Y : CONSTANT CHARACTER := IDENT_CHAR('Y'); + SUBTYPE SA IS A (1..10, 'A'..Y); + + TASK TSK IS + ENTRY E (X : OUT SA); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : OUT SA) DO + CALLED := TRUE; + X := NEW T (1..10, 'A'..IDENT_CHAR('Y')); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; +END C95085M; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085n.ada b/gcc/testsuite/ada/acats/tests/c9/c95085n.ada new file mode 100644 index 000000000..7f7e3a63b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085n.ada @@ -0,0 +1,117 @@ +-- C95085N.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED AFTER AN ENTRY CALL FOR THE +-- CASE OF A PRIVATE TYPE IMPLEMENTED AS A SCALAR TYPE WHERE THE VALUE +-- OF THE FORMAL PARAMETER DOES NOT BELONG TO THE SUBTYPE OF THE ACTUAL +-- PARAMETER. + +-- JWC 10/29/85 +-- JRK 1/15/86 ENSURE THAT EXCEPTION RAISED AFTER CALL, NOT BEFORE +-- CALL. + +WITH REPORT; USE REPORT; +PROCEDURE C95085N IS + +BEGIN + TEST ("C95085N", "CHECK THAT PRIVATE TYPE (SCALAR) RAISES " & + "CONSTRAINT_ERROR AFTER CALL WHEN FORMAL " & + "PARAMETER VALUE IS NOT IN ACTUAL'S SUBTYPE"); + + DECLARE + + CALLED : BOOLEAN := FALSE; + + PACKAGE P IS + TYPE T IS PRIVATE; + DC : CONSTANT T; + + GENERIC PACKAGE PP IS + END PP; + PRIVATE + TYPE T IS NEW INTEGER; + DC : CONSTANT T := -1; + END P; + + TASK TSK IS + ENTRY E (X : OUT P.T); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : OUT P.T) DO + CALLED := TRUE; + X := P.DC; + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + GENERIC + Y : IN OUT P.T; + PACKAGE CALL IS + END CALL; + + PACKAGE BODY CALL IS + BEGIN + TSK.E (Y); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END CALL; + + PACKAGE BODY P IS + Z : T RANGE 0..1 := 0; + PACKAGE BODY PP IS + PACKAGE CALL_Q IS NEW CALL (Z); + END PP; + END P; + + BEGIN + + BEGIN + DECLARE + PACKAGE CALL_Q_NOW IS NEW P.PP; -- START HERE. + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER INVOKED"); + END; + + END; + + RESULT; +END C95085N; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95085o.ada b/gcc/testsuite/ada/acats/tests/c9/c95085o.ada new file mode 100644 index 000000000..f5cd288a3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95085o.ada @@ -0,0 +1,118 @@ +-- C95085O.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS RAISED AFTER AN ENTRY CALL FOR THE +-- CASE OF A PRIVATE TYPE IMPLEMENTED AS AN ACCESS TYPE WHERE THE VALUE +-- OF THE FORMAL PARAMETER DOES NOT BELONG TO THE SUBTYPE OF THE ACTUAL +-- PARAMETER. + +-- JWC 10/30/85 +-- JRK 1/15/86 ENSURE THAT EXCEPTION RAISED AFTER CALL, NOT BEFORE +-- CALL. + +WITH REPORT; USE REPORT; +PROCEDURE C95085O IS + +BEGIN + + TEST ("C95085O", "CHECK THAT PRIVATE TYPE (ACCESS) RAISES " & + "CONSTRAINT_ERROR AFTER CALL WHEN FORMAL " & + "PARAMETER VALUE IS NOT IN ACTUAL'S SUBTYPE"); + + DECLARE + + CALLED : BOOLEAN := FALSE; + + PACKAGE P IS + TYPE T IS PRIVATE; + DC : CONSTANT T; + + GENERIC PACKAGE PP IS + END PP; + PRIVATE + TYPE T IS ACCESS STRING; + DC : CONSTANT T := NEW STRING'("AAA"); + END P; + + TASK TSK IS + ENTRY E (X : IN OUT P.T); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : IN OUT P.T) DO + CALLED := TRUE; + X := P.DC; + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + GENERIC + Y : IN OUT P.T; + PACKAGE CALL IS + END CALL; + + PACKAGE BODY CALL IS + BEGIN + TSK.E (Y); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END CALL; + + PACKAGE BODY P IS + Z : T (1..5) := NEW STRING'("CCCCC"); + PACKAGE BODY PP IS + PACKAGE CALL_Q IS NEW CALL (Z); + END PP; + END P; + + BEGIN + + BEGIN + DECLARE + PACKAGE CALL_Q_NOW IS NEW P.PP; -- START HERE. + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER INVOKED"); + END; + + END; + + RESULT; +END C95085O; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95086a.ada b/gcc/testsuite/ada/acats/tests/c9/c95086a.ada new file mode 100644 index 000000000..e26e8b872 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95086a.ada @@ -0,0 +1,94 @@ +-- C95086A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED AT THE TIME OF CALL WHEN +-- THE VALUE OF AN ACTUAL OUT SCALAR PARAMETER DOES NOT SATISFY THE +-- RANGE CONSTRAINTS OF THE FORMAL PARAMETER. + +-- GLH 7/16/85 +-- JRK 8/23/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95086A IS + + SUBTYPE SUBINT1 IS INTEGER RANGE -10..10; + SUBTYPE SUBINT2 IS INTEGER RANGE -20..20; + + I10 : SUBINT1 := 10; + I20 : SUBINT2 := 20; + + TASK T1 IS + ENTRY E1 (I : OUT SUBINT1); + END T1; + + TASK BODY T1 IS + BEGIN + LOOP + BEGIN + SELECT + ACCEPT E1 (I : OUT SUBINT1) DO + I := SUBINT1'FIRST; + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN ACCEPT E1"); + END; + END LOOP; + END T1; + +BEGIN + + TEST ("C95086A", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "AT THE TIME OF CALL WHEN THE VALUE OF AN " & + "ACTUAL OUT SCALAR PARAMETER DOES NOT " & + "SATISFY THE RANGE CONSTRAINTS OF THE FORMAL " & + "PARAMETER"); + + BEGIN + T1.E1 (SUBINT1(I20)); + IF I20 /= IDENT_INT (-10) THEN + FAILED ("OUT PARAM DID NOT GET CORRECT VALUE - 1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON CALL TO E1 - 1"); + END; + + BEGIN + I20 := IDENT_INT (20); + T1.E1 (I20); + IF I20 /= IDENT_INT (-10) THEN + FAILED ("OUT PARAM DID NOT GET CORRECT VALUE - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON CALL TO E1 - 2"); + END; + + RESULT; + +END C95086A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95086b.ada b/gcc/testsuite/ada/acats/tests/c9/c95086b.ada new file mode 100644 index 000000000..bc222ebc3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95086b.ada @@ -0,0 +1,202 @@ +-- C95086B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR ACCESS PARAMETERS +-- BEFORE AN ENTRY CALL, WHEN AN IN OR IN OUT ACTUAL ACCESS +-- PARAMETER HAS VALUE NULL, BUT WITH CONSTRAINTS DIFFERENT +-- FROM THE FORMAL PARAMETER. +-- +-- SUBTESTS ARE: +-- (A) IN MODE, STATIC ONE DIMENSIONAL BOUNDS. +-- (B) IN OUT MODE, DYNAMIC RECORD DISCRIMINANTS. +-- (C) CASE (A), BUT ACTUAL PARAMETER IS A TYPE CONVERSION. +-- (D) CASE (B), BUT ACTUAL PARAMETER IS A TYPE CONVERSION. + +-- RJW 1/27/86 + +WITH REPORT; USE REPORT; +PROCEDURE C95086B IS + +BEGIN + TEST ( "C95086B", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "BEFORE AN ENTRY CALL, WHEN AN IN OR IN OUT ACTUAL " & + "ACCESS PARAMETER HAS VALUE NULL, BUT WITH CONSTRAINTS " & + "DIFFERENT FROM THE FORMAL PARAMETER" ); + + -------------------------------------------------- + + DECLARE -- (A) + + TYPE E IS (E1, E2, E3, E4); + TYPE T IS ARRAY (E RANGE <>) OF INTEGER; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (E2..E4); + V : A (E1..E2) := NULL; + + TASK T1 IS + ENTRY P (X : SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : SA); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED IN TASK - (A)" ); + END T1; + + BEGIN -- (A) + + T1.P (V); + + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - (A)" ); + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + TYPE ARR IS ARRAY (CHARACTER RANGE <>) OF INTEGER; + + TYPE T (B : BOOLEAN := FALSE; C : CHARACTER := 'A') IS + RECORD + I : INTEGER; + CASE B IS + WHEN FALSE => + J : INTEGER; + WHEN TRUE => + A : ARR ('A' .. C); + END CASE; + END RECORD; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (TRUE, 'C'); + V : A (IDENT_BOOL(FALSE), IDENT_CHAR('B')) := NULL; + + TASK T1 IS + ENTRY P (X : IN OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : IN OUT SA) DO + NULL; + END P; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED IN TASK - (B)" ); + END T1; + + BEGIN -- (B) + + T1.P (V); + + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - (B)" ); + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + TYPE E IS (E1, E2, E3, E4); + TYPE T IS ARRAY (E RANGE <>) OF INTEGER; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (E2..E4); + V : A (E1..E2) := NULL; + + TASK T1 IS + ENTRY P (X : SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : SA) DO + NULL; + END P; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED IN TASK - (C)" ); + END T1; + + BEGIN -- (C) + + T1.P (SA(V)); + + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - (C)" ); + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D) + + TYPE ARR IS ARRAY (CHARACTER RANGE <>) OF INTEGER; + + TYPE T (B : BOOLEAN := FALSE; C : CHARACTER := 'A') IS + RECORD + I : INTEGER; + CASE B IS + WHEN FALSE => + J : INTEGER; + WHEN TRUE => + A : ARR ('A' .. C); + END CASE; + END RECORD; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (TRUE, 'C'); + V : A (IDENT_BOOL(FALSE), IDENT_CHAR('B')) := NULL; + + TASK T1 IS + ENTRY P (X : IN OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : IN OUT SA); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED IN TASK - (D)" ); + END T1; + + BEGIN -- (D) + + T1.P (SA(V)); + + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - (D)" ); + END; -- (D) + + -------------------------------------------------- + + RESULT; +END C95086B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95086c.ada b/gcc/testsuite/ada/acats/tests/c9/c95086c.ada new file mode 100644 index 000000000..9c2050b71 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95086c.ada @@ -0,0 +1,250 @@ +-- C95086C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR ACCESS PARAMETERS +-- AFTER THE ENTRY CALL, WHEN AN IN OUT OR OUT FORMAL +-- ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS +-- DIFFERENT CONSTRAINTS. +-- +-- SUBTESTS ARE: +-- (A) IN OUT MODE, STATIC PRIVATE DISCRIMINANT. +-- (B) OUT MODE, DYNAMIC TWO DIMENSIONAL BOUNDS. +-- (C) SAME AS (A), WITH TYPE CONVERSION. +-- (D) SAME AS (B), WITH TYPE CONVERSION. + +-- RJW 1/29/86 + +WITH REPORT; USE REPORT; +PROCEDURE C95086C IS + +BEGIN + TEST ("C95086C", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "AFTER THE ENTRY CALL, WHEN AN IN OUT OR OUT FORMAL " & + "ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS " & + "DIFFERENT CONSTRAINTS" ); + + -------------------------------------------------- + + DECLARE -- (A) + + PACKAGE PKG IS + TYPE E IS (E1, E2); + TYPE T (D : E := E1) IS PRIVATE; + PRIVATE + TYPE T (D : E := E1) IS + RECORD + I : INTEGER; + CASE D IS + WHEN E1 => + B : BOOLEAN; + WHEN E2 => + C : CHARACTER; + END CASE; + END RECORD; + END PKG; + + USE PKG; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (E2); + V : A (E1) := NULL; + ENTERED : BOOLEAN := FALSE; + + TASK T1 IS + ENTRY P (X : IN OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : IN OUT SA) DO + ENTERED := TRUE; + X := NULL; + END P; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (A)"); + END T1; + + BEGIN -- (A) + + T1.P (V); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT ENTERED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (A)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (A)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (A)"); + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + TYPE T IS ARRAY (CHARACTER RANGE <>, BOOLEAN RANGE <>) OF + INTEGER; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A ('D'..'F', FALSE..FALSE); + V : A (IDENT_CHAR('A') .. IDENT_CHAR('B'), + IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE)) := NULL; + ENTERED : BOOLEAN := FALSE; + + TASK T1 IS + ENTRY P (X : OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : OUT SA) DO + ENTERED := TRUE; + X := NULL; + END P; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (B)"); + END T1; + + BEGIN -- (B) + + T1.P (V); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT ENTERED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (B)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (B)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (B)"); + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + PACKAGE PKG IS + TYPE E IS (E1, E2); + TYPE T (D : E := E1) IS PRIVATE; + PRIVATE + TYPE T (D : E := E1) IS + RECORD + I : INTEGER; + CASE D IS + WHEN E1 => + B : BOOLEAN; + WHEN E2 => + C : CHARACTER; + END CASE; + END RECORD; + END PKG; + + USE PKG; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (E2); + V : A (E1) := NULL; + ENTERED : BOOLEAN := FALSE; + + TASK T1 IS + ENTRY P (X : IN OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : IN OUT SA) DO + ENTERED := TRUE; + X := NULL; + END P; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (C)"); + END T1; + + BEGIN -- (C) + + T1.P (SA(V)); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT ENTERED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (C)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (C)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (C)"); + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D) + + TYPE T IS ARRAY (CHARACTER RANGE <>, BOOLEAN RANGE <>) OF + INTEGER; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A ('D'..'F', FALSE..FALSE); + V : A (IDENT_CHAR('A') .. IDENT_CHAR('B'), + IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE)) := NULL; + ENTERED : BOOLEAN := FALSE; + + TASK T1 IS + ENTRY P (X : OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : OUT SA) DO + ENTERED := TRUE; + X := NULL; + END P; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (D)"); + END T1; + + BEGIN -- (D) + + T1.P (SA(V)); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT ENTERED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (D)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (D)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (D)"); + END; -- (D) + + -------------------------------------------------- + + RESULT; +END C95086C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95086d.ada b/gcc/testsuite/ada/acats/tests/c9/c95086d.ada new file mode 100644 index 000000000..616c025fb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95086d.ada @@ -0,0 +1,142 @@ +-- C95086D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR ACCESS PARAMETERS +-- BEFORE OR AFTER THE ENTRY CALL, WHEN AN UNCONSTRAINED ACTUAL +-- OUT ACCESS PARAMETER DESIGNATES AN OBJECT (PRIOR TO THE +-- ENTRY CALL) WITH CONSTRAINTS DIFFERENT FROM THE FORMAL +-- PARAMETER. +-- +-- SUBTESTS ARE: +-- (A) STATIC LIMITED PRIVATE DISCRIMINANT. +-- (B) DYNAMIC ONE DIMENSIONAL BOUNDS. + +-- RJW 2/3/86 + +WITH REPORT; USE REPORT; +PROCEDURE C95086D IS + +BEGIN + TEST ("C95086D", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "BEFORE AND AFTER THE ENTRY CALL, WHEN AN UNCONSTRAINED " & + "ACTUAL OUT ACCESS PARAMETER DESIGNATES AN OBJECT (PRIOR " & + "TO THE ENTRY CALL) WITH CONSTRAINTS DIFFERENT FROM THE " & + "FORMAL PARAMETER"); + + -------------------------------------------------- + + DECLARE -- (A) + + PACKAGE PKG IS + SUBTYPE INT IS INTEGER RANGE 0..5; + TYPE T (I : INT := 0) IS LIMITED PRIVATE; + PRIVATE + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + TYPE T (I : INT := 0) IS + RECORD + J : INTEGER; + A : ARR (1..I); + END RECORD; + END PKG; + + USE PKG; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (3); + V : A := NEW T (2); + CALLED : BOOLEAN := FALSE; + + TASK T1 IS + ENTRY P (X : OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : OUT SA) DO + CALLED := TRUE; + X := NEW T (3); + END P; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (A)"); + END T1; + + BEGIN -- (A) + + T1.P (V); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE ENTRY CALL - (A)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (A)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (A)"); + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + TYPE A IS ACCESS STRING; + SUBTYPE SA IS A (1..2); + V : A := NEW STRING (IDENT_INT(5) .. IDENT_INT(7)); + CALLED : BOOLEAN := FALSE; + + TASK T1 IS + ENTRY P (X : OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : OUT SA) DO + CALLED := TRUE; + X := NEW STRING (IDENT_INT(1) .. IDENT_INT(2)); + END P; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (B)"); + END T1; + + BEGIN -- (B) + + T1.P (V); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE ENTRY CALL - (B)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (B)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (B)"); + END; -- (B) + + -------------------------------------------------- + + RESULT; +END C95086D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95086e.ada b/gcc/testsuite/ada/acats/tests/c9/c95086e.ada new file mode 100644 index 000000000..4e4f42b95 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95086e.ada @@ -0,0 +1,282 @@ +-- C95086E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED BEFORE OR AFTER THE ENTRY +-- CALL FOR IN OUT ARRAY PARAMETERS, WHERE THE ACTUAL PARAMETER HAS THE +-- FORM OF A TYPE CONVERSION. THE FOLLOWING CASES ARE TESTED: +-- (A) OK CASE. +-- (B) FORMAL CONSTRAINED, BOTH FORMAL AND ACTUAL HAVE SAME NUMBER +-- COMPONENTS PER DIMENSION, BUT ACTUAL INDEX BOUNDS LIE OUTSIDE +-- FORMAL INDEX SUBTYPE. +-- (C) FORMAL CONSTRAINED, FORMAL AND ACTUAL HAVE DIFFERENT NUMBER +-- COMPONENTS PER DIMENSION, BOTH FORMAL AND ACTUAL ARE NULL +-- ARRAYS. +-- (D) FORMAL CONSTRAINED, ACTUAL NULL, WITH INDEX BOUNDS OUTSIDE +-- FORMAL INDEX SUBTYPE. +-- (E) FORMAL UNCONSTRAINED, ACTUAL NULL, WITH INDEX BOUNDS OUTSIDE +-- FORMAL INDEX SUBTYPE FOR NULL DIMENSIONS ONLY. + +-- RJW 2/3/86 +-- TMB 11/15/95 ELIMINATED INCOMPATIBILITY WITH ADA95 +-- TMB 11/19/96 FIXED SLIDING PROBLEM IN SECTION D + +WITH REPORT; USE REPORT; +PROCEDURE C95086E IS + +BEGIN + TEST ("C95086E", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "BEFORE OR AFTER THE ENTRY CALL FOR IN OUT ARRAY " & + "PARAMETERS, WITH THE ACTUAL HAVING THE FORM OF A TYPE " & + "CONVERSION"); + + --------------------------------------------- + + DECLARE -- (A) + + SUBTYPE INDEX IS INTEGER RANGE 1..5; + TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) + OF BOOLEAN; + SUBTYPE FORMAL IS ARRAY_TYPE (1..3, 1..3); + SUBTYPE ACTUAL IS ARRAY_TYPE (1..3, 1..3); + AR : ACTUAL := (1..3 => (1..3 => TRUE)); + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : IN OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : IN OUT FORMAL) DO + CALLED := TRUE; + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (A)"); + END T; + + BEGIN -- (A) + + T.E (FORMAL (AR)); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (A)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (A)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (A)"); + END; -- (A) + + --------------------------------------------- + + DECLARE -- (B) + + SUBTYPE INDEX IS INTEGER RANGE 1..3; + TYPE FORMAL IS ARRAY (INDEX, INDEX) OF BOOLEAN; + TYPE ACTUAL IS ARRAY (3..5, 3..5) OF BOOLEAN; + AR : ACTUAL := (3..5 => (3..5 => FALSE)); + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : IN OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : IN OUT FORMAL) DO + CALLED := TRUE; + X(3, 3) := TRUE; + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (B)"); + END T; + + BEGIN -- (B) + + T.E (FORMAL (AR)); + IF AR(5, 5) /= TRUE THEN + FAILED ("INCORRECT RETURNED VALUE - (B)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (B)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (B)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (B)"); + END; -- (B) + + --------------------------------------------- + + DECLARE -- (C) + + SUBTYPE INDEX IS INTEGER RANGE 1..5; + TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) + OF CHARACTER; + SUBTYPE FORMAL IS ARRAY_TYPE (2..0, 1..3); + AR : ARRAY_TYPE (2..1, 1..3) := (2..1 => (1..3 => ' ')); + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : IN OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : IN OUT FORMAL) DO + IF X'LAST /= 0 AND X'LAST(2) /= 3 THEN + FAILED ("WRONG BOUNDS PASSED - (C)"); + END IF; + CALLED := TRUE; + X := (2..0 => (1..3 => 'A')); + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (C)"); + END T; + + BEGIN -- (C) + + T.E (FORMAL (AR)); + IF AR'LAST /= 1 AND AR'LAST(2) /= 3 THEN + FAILED ("BOUNDS CHANGED - (C)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (C)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (C)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (C)"); + END; -- (C) + + --------------------------------------------- + + DECLARE -- (D) + + SUBTYPE INDEX IS INTEGER RANGE 1..3; + TYPE FORMAL IS ARRAY (INDEX RANGE 1..3, INDEX RANGE 3..1) + OF CHARACTER; + TYPE ACTUAL IS ARRAY (3..5, 5..3) OF CHARACTER; + AR : ACTUAL := (3..5 => (5..3 => ' ')); + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : IN OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : IN OUT FORMAL) DO + IF X'LAST /= 3 AND X'LAST(2) /= 1 THEN + FAILED ("WRONG BOUNDS PASSED - (D)"); + END IF; + CALLED := TRUE; + X := (1..3 => (3..1 => 'A')); + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (D)"); + END T; + + BEGIN -- (D) + + T.E (FORMAL (AR)); + IF AR'LAST /= 5 AND AR'LAST(2) /= 3 THEN + FAILED ("BOUNDS CHANGED - (D)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (D)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (D)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (D)"); + END; -- (D) + + --------------------------------------------- + + DECLARE -- (E) + + SUBTYPE INDEX IS INTEGER RANGE 1..3; + TYPE FORMAL IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) + OF CHARACTER; + TYPE ACTUAL IS ARRAY (POSITIVE RANGE 5..2, + POSITIVE RANGE 1..3) OF CHARACTER; + AR : ACTUAL := (5..2 => (1..3 => ' ')); + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : IN OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : IN OUT FORMAL) DO + IF X'LAST /= 2 AND X'LAST(2) /= 3 THEN + FAILED ("WRONG BOUNDS PASSED - (E)"); + END IF; + CALLED := TRUE; + X := (3..1 => (1..3 => ' ')); + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (E)"); + END T; + + BEGIN -- (E) + + T.E (FORMAL (AR)); + IF AR'LAST /= 2 AND AR'LAST(2) /= 3 THEN + FAILED ("BOUNDS CHANGED - (E)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (E)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (E)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (E)"); + END; -- (E) + + --------------------------------------------- + + RESULT; +END C95086E; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95086f.ada b/gcc/testsuite/ada/acats/tests/c9/c95086f.ada new file mode 100644 index 000000000..00b84441b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95086f.ada @@ -0,0 +1,282 @@ +-- C95086F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED BEFORE OR AFTER THE ENTRY +-- CALL FOR OUT ARRAY PARAMETERS, WHERE THE ACTUAL PARAMETER HAS THE +-- FORM OF A TYPE CONVERSION. THE FOLLOWING CASES ARE TESTED: +-- (A) OK CASE. +-- (B) FORMAL CONSTRAINED, BOTH FORMAL AND ACTUAL HAVE SAME NUMBER +-- COMPONENTS PER DIMENSION, BUT ACTUAL INDEX BOUNDS LIE OUTSIDE +-- FORMAL INDEX SUBTYPE. +-- (C) FORMAL CONSTRAINED, FORMAL AND ACTUAL HAVE DIFFERENT NUMBER +-- COMPONENTS PER DIMENSION, BOTH FORMAL AND ACTUAL ARE NULL +-- ARRAYS. +-- (D) FORMAL CONSTRAINED, ACTUAL NULL, WITH INDEX BOUNDS OUTSIDE +-- FORMAL INDEX SUBTYPE. +-- (E) FORMAL UNCONSTRAINED, ACTUAL NULL, WITH INDEX BOUNDS OUTSIDE +-- FORMAL INDEX SUBTYPE FOR NULL DIMENSIONS ONLY. + +-- RJW 2/3/86 +-- TMB 11/15/95 FIXED INCOMPATIBILITIES WITH ADA95 +-- TMB 11/19/96 FIXED SLIDING PROBLEM IN SECTION D + +WITH REPORT; USE REPORT; +PROCEDURE C95086F IS + +BEGIN + TEST ("C95086F", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "BEFORE OR AFTER THE ENTRY CALL FOR OUT ARRAY PARAMETERS, " & + "WITH THE ACTUAL HAVING THE FORM OF A TYPE CONVERSION"); + + --------------------------------------------- + + DECLARE -- (A) + + SUBTYPE INDEX IS INTEGER RANGE 1..5; + TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) + OF BOOLEAN; + SUBTYPE FORMAL IS ARRAY_TYPE (1..3, 1..3); + SUBTYPE ACTUAL IS ARRAY_TYPE (1..3, 1..3); + AR : ACTUAL; + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : OUT FORMAL) DO + CALLED := TRUE; + X := (1..3 => (1..3 => TRUE)); + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (A)"); + END T; + + BEGIN -- (A) + + T.E (FORMAL (AR)); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (A)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (A)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (A)"); + END; -- (A) + + --------------------------------------------- + + DECLARE -- (B) + + SUBTYPE INDEX IS INTEGER RANGE 1..3; + TYPE FORMAL IS ARRAY (INDEX, INDEX) OF BOOLEAN; + TYPE ACTUAL IS ARRAY (3..5, 3..5) OF BOOLEAN; + AR : ACTUAL; + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : OUT FORMAL) DO + CALLED := TRUE; + X(3, 3) := TRUE; + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (B)"); + END T; + + BEGIN -- (B) + + T.E (FORMAL (AR)); + IF AR(5, 5) /= TRUE THEN + FAILED ("INCORRECT RETURNED VALUE - (B)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (B)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (B)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (B)"); + END; -- (B) + + --------------------------------------------- + + DECLARE -- (C) + + SUBTYPE INDEX IS INTEGER RANGE 1..5; + TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) + OF CHARACTER; + SUBTYPE FORMAL IS ARRAY_TYPE (2..0, 1..3); + AR : ARRAY_TYPE (2..1, 1..3); + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : OUT FORMAL) DO + IF X'LAST /= 0 AND X'LAST(2) /= 3 THEN + FAILED ("WRONG BOUNDS PASSED - (C)"); + END IF; + CALLED := TRUE; + X := (2..0 => (1..3 => 'A')); + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (C)"); + END T; + + BEGIN -- (C) + + T.E (FORMAL (AR)); + IF AR'LAST /= 1 AND AR'LAST(2) /= 3 THEN + FAILED ("BOUNDS CHANGED - (C)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (C)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (C)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (C)"); + END; -- (C) + + --------------------------------------------- + + DECLARE -- (D) + + SUBTYPE INDEX IS INTEGER RANGE 1..3; + TYPE FORMAL IS ARRAY (INDEX RANGE 1..3, INDEX RANGE 3..1) + OF CHARACTER; + TYPE ACTUAL IS ARRAY (3..5, 5..3) OF CHARACTER; + AR : ACTUAL; + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : OUT FORMAL) DO + IF X'LAST /= 3 AND X'LAST(2) /= 1 THEN + FAILED ("WRONG BOUNDS PASSED - (D)"); + END IF; + CALLED := TRUE; + X := (1..3 => (3..1 => 'A')); + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (D)"); + END T; + + BEGIN -- (D) + + T.E (FORMAL (AR)); + IF AR'LAST /= 5 AND AR'LAST(2) /= 3 THEN + FAILED ("BOUNDS CHANGED - (D)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (D)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (D)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (D)"); + END; -- (D) + + --------------------------------------------- + + DECLARE -- (E) + + SUBTYPE INDEX IS INTEGER RANGE 1..3; + TYPE FORMAL IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) + OF CHARACTER; + TYPE ACTUAL IS ARRAY (POSITIVE RANGE 5..2, + POSITIVE RANGE 1..3) OF CHARACTER; + AR : ACTUAL; + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : OUT FORMAL) DO + IF X'LAST /= 2 AND X'LAST(2) /= 3 THEN + FAILED ("WRONG BOUNDS PASSED - (E)"); + END IF; + CALLED := TRUE; + X := (3..1 => (1..3 => ' ' )); + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (E)"); + END T; + + BEGIN -- (E) + + T.E (FORMAL (AR)); + IF AR'LAST /= 2 AND AR'LAST(2) /= 3 THEN + FAILED ("BOUNDS CHANGED - (E)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (E)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (E)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (E)"); + END; -- (E) + + --------------------------------------------- + + RESULT; +END C95086F; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95087a.ada b/gcc/testsuite/ada/acats/tests/c9/c95087a.ada new file mode 100644 index 000000000..535cea40d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95087a.ada @@ -0,0 +1,412 @@ +-- C95087A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT UNCONSTRAINED RECORD, PRIVATE, LIMITED PRIVATE, AND ARRAY +-- FORMAL PARAMETERS USE THE CONSTRAINTS OF ACTUAL PARAMETERS. +-- SUBTESTS ARE: +-- (A) RECORD TYPE, UNCONSTRAINED ACTUALS, DEFAULTS. +-- (B) PRIVATE TYPE, CONSTRAINED ACTUALS, NO DEFAULTS. +-- (C) LIMITED PRIVATE TYPE, UNCONSTRAINED ACTUALS, NO DEFAULTS. +-- (D) ARRAY TYPE, CONSTRAINED ACTUALS, DEFAULTS. + +-- GLH 7/19/85 +-- JRK 8/23/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95087A IS + +BEGIN + TEST ("C95087A", "CHECK USE OF ACTUAL CONSTRAINTS BY " & + "UNCONSTRAINED FORMAL PARAMETERS"); + + DECLARE -- (A) + + PACKAGE PKG IS + + SUBTYPE INT IS INTEGER RANGE 0..100; + + TYPE RECTYPE (CONSTRAINT : INT := 80) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + + REC1 : RECTYPE := (10,10,"0123456789"); + REC2 : RECTYPE := (17,7,"C95087A.........."); + REC3 : RECTYPE := (1,1,"A"); + REC4 : RECTYPE; -- 80. + + TASK T1 IS + ENTRY E1 (REC1 : IN RECTYPE := (2,0,"AB"); + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE); + END T1; + + TASK T2 IS + ENTRY E2 (REC : OUT RECTYPE); + END T2; + END PKG; + + PACKAGE BODY PKG IS + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (REC1 : IN RECTYPE := (2,0,"AB"); + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE) DO + + IF REC1.CONSTRAINT /= IDENT_INT (10) THEN + FAILED ("RECORD TYPE IN PARAMETER " & + "DID NOT USE CONSTRAINT " & + "OF ACTUAL"); + END IF; + IF REC2.CONSTRAINT /= IDENT_INT (17) THEN + FAILED ("RECORD TYPE OUT " & + "PARAMETER DID NOT USE " & + "CONSTRAINT OF ACTUAL"); + END IF; + IF REC3.CONSTRAINT /= IDENT_INT (1) THEN + FAILED ("RECORD TYPE IN OUT " & + "PARAMETER DID NOT USE " & + "CONSTRAINT OF ACTUAL"); + END IF; + REC2 := PKG.REC2; + END E1; + END T1; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (REC : OUT RECTYPE) DO + IF REC.CONSTRAINT /= IDENT_INT (80) THEN + FAILED ("RECORD TYPE OUT " & + "PARAMETER DID " & + "NOT USE CONSTRAINT OF " & + "UNINITIALIZED ACTUAL"); + END IF; + REC := (10,10,"9876543210"); + END E2; + END T2; + END PKG; + + BEGIN -- (A) + + PKG.T1.E1 (PKG.REC1, PKG.REC2, PKG.REC3); + PKG.T2.E2 (PKG.REC4); + + END; -- (A) + + --------------------------------------------- + +B : DECLARE -- (B) + + PACKAGE PKG IS + + SUBTYPE INT IS INTEGER RANGE 0..100; + + TYPE RECTYPE (CONSTRAINT : INT := 80) IS PRIVATE; + + + TASK T1 IS + ENTRY E1 (REC1 : IN RECTYPE; + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE); + END T1; + + TASK T2 IS + ENTRY E2 (REC : OUT RECTYPE); + END T2; + + PRIVATE + TYPE RECTYPE (CONSTRAINT : INT := 80) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + END PKG; + + REC1 : PKG.RECTYPE (10); + REC2 : PKG.RECTYPE (17); + REC3 : PKG.RECTYPE (1); + REC4 : PKG.RECTYPE (10); + + PACKAGE BODY PKG IS + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (REC1 : IN RECTYPE; + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE) DO + IF REC1.CONSTRAINT /= IDENT_INT (10) THEN + FAILED ("PRIVATE TYPE IN " & + "PARAMETER DID " & + "NOT USE CONSTRAINT OF " & + "ACTUAL"); + END IF; + IF REC2.CONSTRAINT /= IDENT_INT (17) THEN + FAILED ("PRIVATE TYPE OUT " & + "PARAMETER DID " & + "NOT USE CONSTRAINT OF " & + "ACTUAL"); + END IF; + IF REC3.CONSTRAINT /= IDENT_INT (1) THEN + FAILED ("PRIVATE TYPE IN OUT " & + "PARAMETER DID " & + "NOT USE CONSTRAINT OF " & + "ACTUAL"); + END IF; + REC2 := B.REC2; + END E1; + END T1; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (REC : OUT RECTYPE) DO + IF REC.CONSTRAINT /= IDENT_INT (10) THEN + FAILED ("PRIVATE TYPE OUT " & + "PARAMETER DID " & + "NOT USE CONSTRAINT OF " & + "UNINITIALIZED ACTUAL"); + END IF; + REC := (10,10,"9876543210"); + END E2; + END T2; + + BEGIN + REC1 := (10,10,"0123456789"); + REC2 := (17,7,"C95087A.........."); + REC3 := (1,1,"A"); + END PKG; + + BEGIN -- (B) + + PKG.T1.E1 (REC1, REC2, REC3); + PKG.T2.E2 (REC4); + + END B; -- (B) + + --------------------------------------------- + +C : DECLARE -- (C) + + PACKAGE PKG IS + + SUBTYPE INT IS INTEGER RANGE 0..100; + + TYPE RECTYPE (CONSTRAINT : INT := 80) IS + LIMITED PRIVATE; + + TASK T1 IS + ENTRY E1 (REC1 : IN RECTYPE; + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE); + END T1; + + TASK T2 IS + ENTRY E2 (REC : OUT RECTYPE); + END T2; + + PRIVATE + TYPE RECTYPE (CONSTRAINT : INT := 80) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + END PKG; + + REC1 : PKG.RECTYPE; -- 10. + REC2 : PKG.RECTYPE; -- 17. + REC3 : PKG.RECTYPE; -- 1. + REC4 : PKG.RECTYPE; -- 80. + + PACKAGE BODY PKG IS + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (REC1 : IN RECTYPE; + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE) DO + IF REC1.CONSTRAINT /= IDENT_INT (10) THEN + FAILED ("LIMITED PRIVATE TYPE IN " & + "PARAMETER DID NOT USE " & + "CONSTRAINT OF ACTUAL"); + END IF; + IF REC2.CONSTRAINT /= IDENT_INT (17) THEN + FAILED ("LIMITED PRIVATE TYPE OUT " & + "PARAMETER DID NOT USE " & + "CONSTRAINT OF " & + "ACTUAL"); + END IF; + IF REC3.CONSTRAINT /= IDENT_INT (1) THEN + FAILED ("LIMITED PRIVATE TYPE IN " & + "OUT PARAMETER DID NOT " & + "USE CONSTRAINT OF ACTUAL"); + END IF; + REC2 := C.REC2; + END E1; + END T1; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (REC : OUT RECTYPE) DO + IF REC.CONSTRAINT /= IDENT_INT (80) THEN + FAILED ("LIMITED PRIVATE TYPE OUT " & + "PARAMETER DID NOT USE " & + "CONSTRAINT OF UNINITIALIZED " & + "ACTUAL"); + END IF; + REC := (10,10,"9876543210"); + END E2; + END T2; + + BEGIN + REC1 := (10,10,"0123456789"); + REC2 := (17,7,"C95087A.........."); + REC3 := (1,1,"A"); + END PKG; + + BEGIN -- (C) + + PKG.T1.E1 (REC1, REC2, REC3); + PKG.T2.E2 (REC4); + + END C; -- (C) + + --------------------------------------------- + +D : DECLARE -- (D) + + TYPE ATYPE IS ARRAY (INTEGER RANGE <>, POSITIVE RANGE <>) OF + CHARACTER; + + A1, A2, A3 : ATYPE (-1..1, 4..5) := (('A','B'), + ('C','D'), + ('E','F')); + + A4 : ATYPE (-1..1, 4..5); + + CA1 : CONSTANT ATYPE (8..9, -7..INTEGER'FIRST) := + (8..9 => (-7..INTEGER'FIRST => 'A')); + + S1 : STRING (1..INTEGER'FIRST) := ""; + S2 : STRING (-5..-7) := ""; + S3 : STRING (1..0) := ""; + + TASK T1 IS + ENTRY E1 (A1 : IN ATYPE := CA1; + A2 : OUT ATYPE; + A3 : IN OUT ATYPE); + END T1; + + TASK T2 IS + ENTRY E2 (A4 : OUT ATYPE); + END T2; + + TASK T3 IS + ENTRY E3 (S1 : IN STRING; + S2 : IN OUT STRING; + S3 : OUT STRING); + END T3; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (A1 : IN ATYPE := CA1; A2 : OUT ATYPE; + A3 : IN OUT ATYPE) DO + IF A1'FIRST(1) /= IDENT_INT (-1) OR + A1'LAST(1) /= IDENT_INT (1) OR + A1'FIRST(2) /= IDENT_INT (4) OR + A1'LAST(2) /= IDENT_INT (5) THEN + FAILED ("ARRAY TYPE IN PARAMETER DID " & + "NOT USE CONSTRAINTS OF ACTUAL"); + END IF; + IF A2'FIRST(1) /= IDENT_INT (-1) OR + A2'LAST(1) /= IDENT_INT (1) OR + A2'FIRST(2) /= IDENT_INT (4) OR + A2'LAST(2) /= IDENT_INT (5) THEN + FAILED ("ARRAY TYPE OUT PARAMETER DID " & + "NOT USE CONSTRAINTS OF ACTUAL"); + END IF; + IF A3'FIRST(1) /= IDENT_INT (-1) OR + A3'LAST(1) /= IDENT_INT (1) OR + A3'FIRST(2) /= IDENT_INT (4) OR + A3'LAST(2) /= IDENT_INT (5) THEN + FAILED ("ARRAY TYPE IN OUT PARAMETER " & + "DID NOT USE CONSTRAINTS OF " & + "ACTUAL"); + END IF; + A2 := D.A2; + END E1; + END T1; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (A4 : OUT ATYPE) DO + IF A4'FIRST(1) /= IDENT_INT (-1) OR + A4'LAST(1) /= IDENT_INT (1) OR + A4'FIRST(2) /= IDENT_INT (4) OR + A4'LAST(2) /= IDENT_INT (5) THEN + FAILED ("ARRAY TYPE OUT PARAMETER DID " & + "NOT USE CONSTRAINTS OF " & + "UNINITIALIZED ACTUAL"); + END IF; + A4 := A2; + END E2; + END T2; + + TASK BODY T3 IS + BEGIN + ACCEPT E3 (S1 : IN STRING; + S2 : IN OUT STRING; + S3 : OUT STRING) DO + IF S1'FIRST /= IDENT_INT (1) OR + S1'LAST /= IDENT_INT (INTEGER'FIRST) THEN + FAILED ("STRING TYPE IN PARAMETER DID " & + "NOT USE CONSTRAINTS OF ACTUAL " & + "NULL STRING"); + END IF; + IF S2'FIRST /= IDENT_INT (-5) OR + S2'LAST /= IDENT_INT (-7) THEN + FAILED ("STRING TYPE IN OUT PARAMETER " & + "DID NOT USE CONSTRAINTS OF " & + "ACTUAL NULL STRING"); + END IF; + IF S3'FIRST /= IDENT_INT (1) OR + S3'LAST /= IDENT_INT (0) THEN + FAILED ("STRING TYPE OUT PARAMETER DID NOT " & + "USE CONSTRAINTS OF ACTUAL NULL " & + "STRING"); + END IF; + S3 := ""; + END E3; + END T3; + + BEGIN -- (D) + + T1.E1 (A1, A2, A3); + T2.E2 (A4); + T3.E3 (S1, S2, S3); + + END D; -- (D) + + RESULT; +END C95087A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95087b.ada b/gcc/testsuite/ada/acats/tests/c9/c95087b.ada new file mode 100644 index 000000000..1d6c87826 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95087b.ada @@ -0,0 +1,267 @@ +-- C95087B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT ASSIGNMENTS TO ENTRY FORMAL PARAMETERS OF UNCONSTRAINED +-- RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITHOUT DEFAULT +-- CONSTRAINTS RAISE CONSTRAINT_ERROR IF AN ATTEMPT IS MADE TO CHANGE +-- THE CONSTRAINT OF THE ACTUAL PARAMETER. +-- SUBTESTS ARE: +-- (A) RECORD TYPE. +-- (B) PRIVATE TYPE. +-- (C) LIMITED PRIVATE TYPE. + +-- RJW 1/10/86 + +WITH REPORT; USE REPORT; +PROCEDURE C95087B IS + +BEGIN + + TEST ( "C95087B", "CHECK ASSIGNMENT TO ENTRY FORMAL PARAMETERS " & + "OF UNCONSTRAINED TYPE (WITH NO DEFAULT)" ); + + -------------------------------------------------- + + DECLARE -- (A) + + PACKAGE PKG IS + + TYPE RECTYPE (CONSTRAINT : INTEGER) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + + TASK T IS + ENTRY E (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE); + END T; + + END PKG; + + REC9 : PKG.RECTYPE(IDENT_INT(9)) := + (IDENT_INT(9), 9, "123456789"); + REC6 : PKG.RECTYPE(IDENT_INT(6)) := + (IDENT_INT(6), 5, "AEIOUY"); + + PACKAGE BODY PKG IS + + TASK BODY T IS + + REC4 : CONSTANT RECTYPE(IDENT_INT(4)) := + (IDENT_INT(4), 4, "OOPS"); + + BEGIN + ACCEPT E (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE) DO + + BEGIN -- (A.1) + REC9 := REC6; + FAILED ("CONSTRAINT_ERROR NOT RAISED " & + "- A.1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED " & + "- A.1"); + END; -- (A.1) + + BEGIN -- (A.2) + REC6 := REC4; + FAILED ("CONSTRAINT_ERROR NOT RAISED " & + "- A.2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED " & + "- A.2"); + END; -- (A.2) + + REC9 := (IDENT_INT(9), 9, "987654321"); + + END E; + END T; + END PKG; + + BEGIN -- (A) + + PKG.T.E (REC9, REC6); + + IF REC9.STRFIELD /= IDENT_STR("987654321") THEN + FAILED ("ASSIGNMENT TO REC9 FAILED - (A)"); + END IF; + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + PACKAGE PKG IS + + TYPE RECTYPE (CONSTRAINT : INTEGER) IS PRIVATE; + + TASK T IS + ENTRY E (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE); + END T; + + PRIVATE + TYPE RECTYPE (CONSTRAINT : INTEGER) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + END PKG; + + REC9 : PKG.RECTYPE(9); + REC6 : PKG.RECTYPE(6); + + PACKAGE BODY PKG IS + + TASK BODY T IS + + REC4 : CONSTANT RECTYPE(4) := (4, 4, "OOPS"); + + BEGIN + ACCEPT E (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE) DO + + BEGIN -- (B.1) + REC9 := REC6; + FAILED ("CONSTRAINT_ERROR NOT RAISED " & + "- B.1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED " & + "- B.1"); + END; -- (B.1) + + BEGIN -- (B.2) + REC6 := REC4; + FAILED ("CONSTRAINT_ERROR NOT RAISED " & + "- B.2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED " & + "- B.2"); + END; -- (B.2) + + END E; + END T; + + BEGIN + REC9 := (9, 9, "123456789"); + REC6 := (6, 5, "AEIOUY"); + END PKG; + + BEGIN -- (B) + + PKG.T.E (REC9, REC6); + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + PACKAGE PKG IS + + TYPE RECTYPE (CONSTRAINT : INTEGER) IS LIMITED PRIVATE; + + TASK T IS + ENTRY E (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE); + END T; + + PRIVATE + TYPE RECTYPE (CONSTRAINT : INTEGER) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + END PKG; + + REC6 : PKG.RECTYPE(IDENT_INT(6)); + REC9 : PKG.RECTYPE(IDENT_INT(9)); + + PACKAGE BODY PKG IS + + TASK BODY T IS + + REC4 : CONSTANT RECTYPE(4) := (4, 4, "OOPS"); + + BEGIN + ACCEPT E (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE) DO + + BEGIN -- (C.1) + REC9 := REC6; + FAILED ("CONSTRAINT_ERROR NOT RAISED " & + "- C.1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED " & + "- C.1"); + END; -- (C.1) + + BEGIN -- (C.2) + REC6 := REC4; + FAILED ("CONSTRAINT_ERROR NOT RAISED " & + "- C.2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED " & + "- C.2"); + END; -- (C.2) + + END E; + END T; + + BEGIN + REC6 := (6, 5, "AEIOUY"); + REC9 := (9, 9, "123456789"); + END PKG; + + BEGIN -- (C) + + PKG.T.E (REC9, REC6); + + END; -- (C) + + -------------------------------------------------- + + RESULT; + +END C95087B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95087c.ada b/gcc/testsuite/ada/acats/tests/c9/c95087c.ada new file mode 100644 index 000000000..2061af4bc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95087c.ada @@ -0,0 +1,299 @@ +-- C95087C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT ASSIGNMENTS TO ENTRY FORMAL PARAMETERS OF UNCONSTRAINED +-- RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITH DEFAULT +-- CONSTRAINTS RAISE CONSTRAINT_ERROR IF THE ACTUAL PARAMETER IS +-- CONSTRAINED AND THE CONSTRAINT VALUES OF THE OBJECT BEING +-- ASSIGNED TO DO NOT SATISFY THOSE OF THE ACTUAL PARAMETER. + +-- SUBTESTS ARE: +-- (A) CONSTRAINED ACTUAL PARAMETERS OF RECORD TYPE. +-- (B) CONSTRAINED ACTUAL PARAMETERS OF PRIVATE TYPE. +-- (C) CONSTRAINED ACTUAL PARAMETERS OF LIMITED PRIVATE TYPE. + +-- RJW 1/15/86 + +WITH REPORT; USE REPORT; +PROCEDURE C95087C IS + +BEGIN + + TEST ( "C95087C", "CHECK ASSIGNMENTS TO ENTRY FORMAL " & + "PARAMETERS OF UNCONSTRAINED TYPES " & + "(WITH DEFAULTS)" ); + + -------------------------------------------------- + + DECLARE -- (A) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + + REC91,REC92,REC93 : RECTYPE(9); + REC_OOPS : RECTYPE(4); + + TASK T IS + ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + END T; + + END PKG; + + PACKAGE BODY PKG IS + + TASK BODY T IS + BEGIN + ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) DO + + IF (NOT REC1'CONSTRAINED) OR + (REC1.CONSTRAINT /= IDENT_INT(9)) THEN + FAILED ( "CONSTRAINT ON RECORD TYPE " & + "IN PARAMETER NOT RECOGNIZED" ); + END IF; + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER. + REC2 := REC_OOPS; + FAILED ( "CONSTRAINT_ERROR NOT " & + "RAISED - A.1" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION " & + "RAISED - A.1" ); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER. + REC3 := REC_OOPS; + FAILED ( "CONSTRAINT_ERROR NOT " & + "RAISED - A.2" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION " & + "RAISED - A.2" ); + END; + + END E; + END T; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + BEGIN -- (A) + + PKG.T.E (PKG.REC91, PKG.REC92, PKG.REC93); + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS PRIVATE; + + TASK T IS + ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + END T; + + PRIVATE + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + END PKG; + + REC91, REC92, REC93 : PKG.RECTYPE(9); + REC_OOPS : PKG.RECTYPE(4); + + PACKAGE BODY PKG IS + + TASK BODY T IS + BEGIN + ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) DO + + IF (NOT REC1'CONSTRAINED) OR + (REC1.CONSTRAINT /= IDENT_INT(9)) THEN + FAILED ( "CONSTRAINT ON PRIVATE TYPE " & + "IN PARAMETER NOT RECOGNIZED" ); + END IF; + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER. + REC2 := REC_OOPS; + FAILED ( "CONSTRAINT_ERROR NOT " & + "RAISED - B.1" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION " & + "RAISED - B.1" ); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER. + REC3 := REC_OOPS; + FAILED ( "CONSTRAINT_ERROR NOT " & + "RAISED - B.2" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION " & + "RAISED - B.2" ); + END; + + END E; + END T; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + BEGIN -- (B) + + PKG.T.E (REC91, REC92, REC93); + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + LIMITED PRIVATE; + + TASK T IS + ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + END T; + + PRIVATE + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + END PKG; + + REC91,REC92,REC93 : PKG.RECTYPE(9); + REC_OOPS : PKG.RECTYPE(4); + + PACKAGE BODY PKG IS + + TASK BODY T IS + BEGIN + ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) DO + + IF (NOT REC1'CONSTRAINED) OR + (REC1.CONSTRAINT /= 9) THEN + FAILED ( "CONSTRAINT ON LIMITED " & + "PRIVATE TYPE IN PARAMETER " & + "NOT RECOGNIZED" ); + END IF; + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER. + REC2 := REC_OOPS; + FAILED ( "CONSTRAINT_ERROR NOT " & + "RAISED - C.1" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION " & + "RAISED - C.1" ); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER. + REC3 := REC_OOPS; + FAILED ( "CONSTRAINT_ERROR NOT RAISED " & + "- C.2" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION " & + "RAISED - C.2" ); + END; + + END E; + END T; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + BEGIN -- (C) + + PKG.T.E (REC91, REC92, REC93); + + END; -- (C) + + -------------------------------------------------- + + RESULT; + +END C95087C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95087d.ada b/gcc/testsuite/ada/acats/tests/c9/c95087d.ada new file mode 100644 index 000000000..6e44913b4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95087d.ada @@ -0,0 +1,268 @@ +-- C95087D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT ASSIGNMENTS TO ENTRY FORMAL PARAMETERS OF UNCONSTRAINED +-- RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITH DEFAULT +-- CONSTRAINTS DO NOT RAISE CONSTRAINT_ERROR IF THE ACTUAL PARAMETER +-- IS UNCONSTRAINED, EVEN IF THE CONSTRAINT VALUES OF THE OBJECT +-- BEING ASSIGNED ARE DIFFERENT THAN THOSE OF THE ACTUAL PARAMETER. + +-- SUBTESTS ARE: +-- (A) UNCONSTRAINED ACTUAL PARAMETERS OF RECORD TYPE. +-- (B) UNCONSTRAINED ACTUAL PARAMETERS OF PRIVATE TYPE. +-- (C) UNCONSTRAINED ACTUAL PARAMETERS OF LIMITED PRIVATE TYPE. + +-- RJW 1/17/86 + +WITH REPORT; USE REPORT; +PROCEDURE C95087D IS + +BEGIN + + TEST ( "C95087D", "CHECK ASSIGNMENTS TO ENTRY FORMAL PARAMETERS " & + "OF UNCONSTRAINED TYPES WITH UNCONSTRAINED " & + "ACTUAL PARAMETERS"); + + -------------------------------------------------- + + DECLARE -- (A) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + + TASK T IS + ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + END T; + + END PKG; + + REC91, REC92, REC93 : PKG.RECTYPE := + (IDENT_INT(5), 5, IDENT_STR( "12345")); + REC_OOPS : PKG.RECTYPE; + + PACKAGE BODY PKG IS + + TASK BODY T IS + BEGIN + ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) DO + + IF NOT REC1'CONSTRAINED THEN + FAILED ( "REC1 IS NOT CONSTRAINED - A.1"); + END IF; + IF REC1.CONSTRAINT /= IDENT_INT(9) THEN + FAILED ( "REC1 CONSTRAINT IS NOT 9 " & + "- A.1"); + END IF; + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER. + REC2 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - A.1"); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER. + REC3 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - A.2"); + END; + + END E; + END T; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + USE PKG; + + BEGIN -- (A) + + PKG.T.E (REC91, REC92, REC93); + IF (REC92 /= REC_OOPS) OR (REC93 /= REC_OOPS) THEN + FAILED ( "RESULTANT VALUE OF REC92 OR REC93 INCORRECT"); + END IF; + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS PRIVATE; + + TASK T IS + ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + END T; + + PRIVATE + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + END PKG; + + REC91, REC92, REC93 : PKG.RECTYPE; + REC_OOPS : PKG.RECTYPE; + + PACKAGE BODY PKG IS + + TASK BODY T IS + BEGIN + ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) DO + + IF REC3'CONSTRAINED THEN + FAILED ( "REC3 IS CONSTRAINED - B.1"); + END IF; + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER. + REC2 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - B.1"); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER. + REC3 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - B.2"); + END; + + END E; + END T; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + BEGIN -- (B) + + PKG.T.E (REC91, REC92, REC93); + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + LIMITED PRIVATE; + + TASK T IS + ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + END T; + + PRIVATE + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + END PKG; + + REC91, REC92, REC93 : PKG.RECTYPE; + REC_OOPS : PKG.RECTYPE; + + PACKAGE BODY PKG IS + + TASK BODY T IS + BEGIN + ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) DO + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER. + REC2 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - C.1"); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER. + REC3 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - C.2"); + END; + + END E; + END T; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + BEGIN -- (C) + + PKG.T.E (REC91, REC92, REC93); + + END; -- (C) + + -------------------------------------------------- + + RESULT; + +END C95087D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95088a.ada b/gcc/testsuite/ada/acats/tests/c9/c95088a.ada new file mode 100644 index 000000000..053abebdd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95088a.ada @@ -0,0 +1,85 @@ +-- C95088A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT ACTUAL PARAMETERS ARE EVALUATED AND IDENTIFIED AT THE +-- TIME OF CALL. + +-- GLH 7/10/85 + +WITH REPORT; USE REPORT; + +PROCEDURE C95088A IS + + TYPE VECTOR IS ARRAY (1..10) OF INTEGER; + TYPE PTRINT IS ACCESS INTEGER; + + I : INTEGER := 1; + A : VECTOR := (1,2,3,4,5,6,7,8,9,10); + P1 : PTRINT := NEW INTEGER'(2); + P2 : PTRINT := P1; + + TASK T1 IS + ENTRY E1 (I : OUT INTEGER; J : OUT INTEGER); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (I : OUT INTEGER; J : OUT INTEGER) DO + I := 10; + J := -1; + END E1; + END T1; + + TASK T2 IS + ENTRY E2 (P : OUT PTRINT; I : OUT INTEGER); + END T2; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (P : OUT PTRINT; I : OUT INTEGER) DO + P := NEW INTEGER'(3); + I := 5; + END E2; + END T2; + +BEGIN + + TEST ("C95088A", "CHECK THAT ACTUAL PARAMETERS ARE EVALUATED " & + "AND IDENTIFIED AT THE TIME OF CALL"); + + COMMENT ("FIRST CALL"); + T1.E1 (I, A(I)); + IF (A /= (-1,2,3,4,5,6,7,8,9,10)) THEN + FAILED ("A(I) EVALUATED UPON RETURN"); + END IF; + + COMMENT ("SECOND CALL"); + T2.E2 (P1, P1.ALL); + IF (P2.ALL /= 5) THEN + FAILED ("P1.ALL EVALUATED UPON RETURN"); + END IF; + + RESULT; + +END C95088A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95089a.ada b/gcc/testsuite/ada/acats/tests/c9/c95089a.ada new file mode 100644 index 000000000..b66897cc7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95089a.ada @@ -0,0 +1,175 @@ +-- C95089A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT ALL PERMITTED FORMS OF VARIABLE NAMES ARE PERMITTED +-- AS ACTUAL PARAMETERS. + +-- GLH 7/25/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95089A IS + + SUBTYPE INT IS INTEGER RANGE 1..3; + + TYPE REC (N : INT) IS + RECORD + S : STRING (1..N); + END RECORD; + + TYPE PTRSTR IS ACCESS STRING; + + R1, R2, R3 : REC (3); + S1, S2, S3 : STRING (1..3); + PTRTBL : ARRAY (1..3) OF PTRSTR; + + TASK T1 IS + ENTRY E1 (S1 : IN STRING; S2: IN OUT STRING; + S3 : OUT STRING); + END T1; + + TASK BODY T1 IS + BEGIN + LOOP + SELECT + ACCEPT E1 (S1 : IN STRING; S2: IN OUT STRING; + S3 : OUT STRING) DO + S3 := S2; + S2 := S1; + END E1; + OR + TERMINATE; + END SELECT; + END LOOP; + END T1; + + TASK T2 IS + ENTRY E2 (C1 : IN CHARACTER; C2 : IN OUT CHARACTER; + C3 : OUT CHARACTER); + END T2; + + TASK BODY T2 IS + BEGIN + LOOP + SELECT + ACCEPT E2 (C1 : IN CHARACTER; C2 : IN OUT CHARACTER; + C3 : OUT CHARACTER) DO + C3 := C2; + C2 := C1; + END E2; + OR + TERMINATE; + END SELECT; + END LOOP; + END T2; + + FUNCTION F1 (X : INT) RETURN PTRSTR IS + BEGIN + RETURN PTRTBL (X); + END F1; + + FUNCTION "+" (S1, S2 : STRING) RETURN PTRSTR IS + BEGIN + RETURN PTRTBL (CHARACTER'POS(S1(1))-CHARACTER'POS('A')+1); + END "+"; + +BEGIN + + TEST ("C95089A", "CHECK THAT ALL PERMITTED FORMS OF VARIABLE " & + "NAMES ARE PERMITTED AS ACTUAL PARAMETERS"); + + S1 := "AAA"; + S2 := "BBB"; + T1.E1 (S1, S2, S3); + IF S2 /= "AAA" OR S3 /= "BBB" THEN + FAILED ("SIMPLE VARIABLE AS AN ACTUAL PARAMETER NOT WORKING"); + END IF; + + S1 := "AAA"; + S2 := "BBB"; + S3 := IDENT_STR ("CCC"); + T2.E2 (S1(1), S2(IDENT_INT(1)), S3(1)); + IF S2 /= "ABB" OR S3 /= "BCC" THEN + FAILED ("INDEXED COMPONENT AS AN ACTUAL PARAMETER NOT " & + "WORKING"); + END IF; + + R1.S := "AAA"; + R2.S := "BBB"; + T1.E1 (R1.S, R2.S, R3.S); + IF R2.S /= "AAA" OR R3.S /= "BBB" THEN + FAILED ("SELECTED COMPONENT AS AN ACTUAL PARAMETER " & + "NOT WORKING"); + END IF; + + S1 := "AAA"; + S2 := "BBB"; + T1.E1 (S1(1..IDENT_INT(2)), S2(1..2), + S3(IDENT_INT(1)..IDENT_INT(2))); + IF S2 /= "AAB" OR S3 /= "BBC" THEN + FAILED ("SLICE AS AN ACTUAL PARAMETER NOT WORKING"); + END IF; + + PTRTBL(1) := NEW STRING'("AAA"); + PTRTBL(2) := NEW STRING'("BBB"); + PTRTBL(3) := NEW STRING'("CCC"); + T1.E1 (F1(1).ALL, F1(2).ALL, F1(IDENT_INT(3)).ALL); + IF PTRTBL(2).ALL /= "AAA" OR PTRTBL(3).ALL /= "BBB" THEN + FAILED ("SELECTED COMPONENT OF FUNCTION VALUE AS AN ACTUAL " & + "PARAMETER NOT WORKING"); + END IF; + + PTRTBL(1) := NEW STRING'("AAA"); + PTRTBL(2) := NEW STRING'("BBB"); + PTRTBL(3) := NEW STRING'("CCC"); + S1 := IDENT_STR("AAA"); + S2 := IDENT_STR("BBB"); + S3 := IDENT_STR("CCC"); + T1.E1 ("+"(S1,S1).ALL, "+"(S2,S2).ALL, "+"(S3,S3).ALL); + IF PTRTBL(2).ALL /= "AAA" OR PTRTBL(3).ALL /= "BBB" THEN + FAILED ("SELECTED COMPONENT OF OVERLOADED OPERATOR " & + "FUNCTION VALUE AS AN ACTUAL PARAMETER NOT WORKING"); + END IF; + + PTRTBL(1) := NEW STRING'("AAA"); + PTRTBL(2) := NEW STRING'("BBB"); + PTRTBL(3) := NEW STRING'("CCC"); + T2.E2 (F1(1)(1), F1(IDENT_INT(2))(1), F1(3)(IDENT_INT(1))); + IF PTRTBL(2).ALL /= "ABB" OR PTRTBL(3).ALL /= "BCC" THEN + FAILED ("INDEXED COMPONENT OF FUNCTION VALUE AS AN ACTUAL " & + "PARAMETER NOT WORKING"); + END IF; + + PTRTBL(1) := NEW STRING'("AAA"); + PTRTBL(2) := NEW STRING'("BBB"); + PTRTBL(3) := NEW STRING'("CCC"); + T1.E1 (F1(1)(2..3), F1(2)(IDENT_INT(2)..3), + F1(3)(2..IDENT_INT(3))); + IF PTRTBL(2).ALL /= "BAA" OR PTRTBL(3).ALL /= "CBB" THEN + FAILED ("SLICE OF FUNCTION VALUE AS AN ACTUAL PARAMETER " & + "NOT WORKING"); + END IF; + + RESULT; + +END C95089A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95090a.ada b/gcc/testsuite/ada/acats/tests/c9/c95090a.ada new file mode 100644 index 000000000..24dc17981 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95090a.ada @@ -0,0 +1,128 @@ +-- C95090A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT ARRAYS THAT ARE COMPONENTS OF RECORDS ARE PASSED CORRECTLY +-- TO ENTRIES. SPECIFICALLY, +-- (A) CHECK ALL PARAMETER MODES. + +-- GLH 7/25/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95090A IS + +BEGIN + TEST ("C95090A", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " & + "RECORDS ARE PASSED CORRECTLY TO ENTRIES"); + + -------------------------------------------- + + DECLARE -- (A) + + TYPE ARRAY_TYPE IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + SUBTYPE ARRAY_SUBTYPE IS ARRAY_TYPE (1..IDENT_INT(5)); + + TYPE RECORD_TYPE IS + RECORD + I : INTEGER; + A : ARRAY_SUBTYPE; + END RECORD; + + REC : RECORD_TYPE := (I => 23, + A => (1..3 => IDENT_INT(7), 4..5 => 9)); + BOOL : BOOLEAN; + + TASK T1 IS + ENTRY E1 (ARR : ARRAY_TYPE); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (ARR : ARRAY_TYPE) DO + IF ARR /= (7, 7, 7, 9, 9) THEN + FAILED ("IN PARAMETER NOT PASSED CORRECTLY"); + END IF; + IF ARR'FIRST /= IDENT_INT (1) OR + ARR'LAST /= IDENT_INT (5) THEN + FAILED ("WRONG BOUNDS FOR IN PARAMETER"); + END IF; + END E1; + END T1; + + TASK T2 IS + ENTRY E2 (ARR : IN OUT ARRAY_TYPE); + END T2; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (ARR : IN OUT ARRAY_TYPE) DO + IF ARR /= (7, 7, 7, 9, 9) THEN + FAILED ("IN OUT PARAMETER NOT PASSED " & + "CORRECTLY"); + END IF; + IF ARR'FIRST /= IDENT_INT (1) OR + ARR'LAST /= IDENT_INT (5) THEN + FAILED ("WRONG BOUNDS FOR IN OUT PARAMETER"); + END IF; + ARR := (ARR'RANGE => 5); + END E2; + END T2; + + TASK T3 IS + ENTRY E3 (ARR : OUT ARRAY_TYPE); + END T3; + + TASK BODY T3 IS + BEGIN + ACCEPT E3 (ARR : OUT ARRAY_TYPE) DO + IF ARR'FIRST /= IDENT_INT (1) OR + ARR'LAST /= IDENT_INT (5) THEN + FAILED ("WRONG BOUNDS FOR OUT PARAMETER"); + END IF; + ARR := (ARR'RANGE => 3); + END E3; + END T3; + + BEGIN -- (A) + + T1.E1 (REC.A); + IF REC.A /= (7, 7, 7, 9, 9) THEN + FAILED ("IN PARAM CHANGED BY PROCEDURE"); + END IF; + + T2.E2 (REC.A); + IF REC.A /= (5, 5, 5, 5, 5) THEN + FAILED ("IN OUT PARAM RETURNED INCORRECTLY"); + END IF; + + T3.E3 (REC.A); + IF REC.A /= (3, 3, 3, 3, 3) THEN + FAILED ("OUT PARAM RETURNED INCORRECTLY"); + END IF; + + END; -- (A) + + -------------------------------------------- + + RESULT; +END C95090A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95092a.ada b/gcc/testsuite/ada/acats/tests/c9/c95092a.ada new file mode 100644 index 000000000..47e96b548 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95092a.ada @@ -0,0 +1,193 @@ +-- C95092A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT FOR ENTRIES OF TASKS, DEFAULT VALUES OF ALL TYPES CAN +-- BE GIVEN FOR A FORMAL PARAMETER. + +-- HISTORY: +-- DHH 03/22/88 CREATED ORIGINAL TEST. + +WITH REPORT; USE REPORT; +PROCEDURE C95092A IS + + SUBTYPE INT IS INTEGER RANGE 1 ..10; + TYPE FLT IS DIGITS 5; + TYPE FIX IS DELTA 0.125 RANGE 0.0 .. 10.0; + TYPE ENUM IS (RED, BLUE, YELLOW); + SUBTYPE CHAR IS CHARACTER RANGE 'A' .. 'F'; + TYPE ARR IS ARRAY(1 .. 3) OF INTEGER; + TYPE REC IS + RECORD + A : INT; + B : ENUM; + C : CHAR; + END RECORD; + + FUNCTION IDENT_FLT(E : FLT) RETURN FLT IS + BEGIN + IF EQUAL(3,3) THEN + RETURN E; + ELSE + RETURN 0.0; + END IF; + END IDENT_FLT; + + FUNCTION IDENT_FIX(E : FIX) RETURN FIX IS + BEGIN + IF EQUAL(3,3) THEN + RETURN E; + ELSE + RETURN 0.0; + END IF; + END IDENT_FIX; + + FUNCTION IDENT_ENUM(E : ENUM) RETURN ENUM IS + BEGIN + IF EQUAL(3,3) THEN + RETURN E; + ELSE + RETURN YELLOW; + END IF; + END IDENT_ENUM; + + FUNCTION IDENT_CHAR(E : CHAR) RETURN CHAR IS + BEGIN + IF EQUAL(3,3) THEN + RETURN E; + ELSE + RETURN 'F'; + END IF; + END IDENT_CHAR; + + FUNCTION IDENT_ARR(E : ARR) RETURN ARR IS + Z : ARR := (3,2,1); + BEGIN + IF EQUAL(3,3) THEN + RETURN E; + ELSE + RETURN Z; + END IF; + END IDENT_ARR; + + FUNCTION IDENT_REC(E : REC) RETURN REC IS + Z : REC := (10, YELLOW, 'F'); + BEGIN + IF EQUAL(3,3) THEN + RETURN E; + ELSE + RETURN Z; + END IF; + END IDENT_REC; + + TASK TEST_DEFAULTS IS + ENTRY BOOL(G : BOOLEAN := TRUE); + ENTRY INTEGR(X : IN INT := 5); + ENTRY FLOAT(Y : IN FLT := 1.25); + ENTRY FIXED(Z : IN FIX := 1.0); + ENTRY ENUMERAT(A : IN ENUM := RED); + ENTRY CHARACTR(B : IN CHAR := 'A'); + ENTRY ARRY(C : IN ARR := (1, 2, 3)); + ENTRY RECD(D : IN REC := (5, RED, 'A')); + END TEST_DEFAULTS; + + TASK BODY TEST_DEFAULTS IS + BEGIN + + ACCEPT BOOL(G : BOOLEAN := TRUE) DO + IF G /= IDENT_BOOL(TRUE) THEN + FAILED("BOOLEAN DEFAULT FAILED"); + END IF; + END BOOL; + + ACCEPT INTEGR(X : IN INT := 5) DO + IF X /= IDENT_INT(5) THEN + FAILED("INTEGER DEFAULT FAILED"); + END IF; + END INTEGR; + + ACCEPT FLOAT(Y : IN FLT := 1.25) DO + IF Y /= IDENT_FLT(1.25) THEN + FAILED("FLOAT DEFAULT FAILED"); + END IF; + END FLOAT; + + ACCEPT FIXED(Z : IN FIX := 1.0) DO + IF Z /= IDENT_FIX(1.0) THEN + FAILED("FIXED DEFAULT FAILED"); + END IF; + END FIXED; + + ACCEPT ENUMERAT(A : IN ENUM := RED) DO + IF A /= IDENT_ENUM(RED) THEN + FAILED("ENUMERATION DEFAULT FAILED"); + END IF; + END ENUMERAT; + + ACCEPT CHARACTR(B : IN CHAR := 'A') DO + IF B /= IDENT_CHAR('A') THEN + FAILED("CHARACTER DEFAULT FAILED"); + END IF; + END CHARACTR; + + ACCEPT ARRY(C : IN ARR := (1, 2, 3)) DO + FOR I IN 1 ..3 LOOP + IF C(I) /= IDENT_INT(I) THEN + FAILED("ARRAY " & INTEGER'IMAGE(I) & + "DEFAULT FAILED"); + END IF; + END LOOP; + END ARRY; + + ACCEPT RECD(D : IN REC := (5, RED, 'A')) DO + IF D.A /= IDENT_INT(5) THEN + FAILED("RECORD INTEGER DEFAULT FAILED"); + END IF; + IF D.B /= IDENT_ENUM(RED) THEN + FAILED("RECORD ENUMERATION DEFAULT FAILED"); + END IF; + IF D.C /= IDENT_CHAR('A') THEN + FAILED("RECORD CHARACTER DEFAULT FAILED"); + END IF; + END RECD; + + END TEST_DEFAULTS; + +BEGIN + + TEST("C95092A", "CHECK THAT FOR ENTRIES OF TASKS, DEFAULT " & + "VALUES OF ALL TYPES CAN BE GIVEN FOR A FORMAL " & + "PARAMETER"); + + TEST_DEFAULTS.BOOL; + TEST_DEFAULTS.INTEGR; + TEST_DEFAULTS.FLOAT; + TEST_DEFAULTS.FIXED; + TEST_DEFAULTS.ENUMERAT; + TEST_DEFAULTS.CHARACTR; + TEST_DEFAULTS.ARRY; + TEST_DEFAULTS.RECD; + + RESULT; +END C95092A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95093a.ada b/gcc/testsuite/ada/acats/tests/c9/c95093a.ada new file mode 100644 index 000000000..9c443faae --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95093a.ada @@ -0,0 +1,87 @@ +-- C95093A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE DEFAULT EXPRESSIONS OF FORMAL PARAMETERS ARE EVALUATED +-- EACH TIME THEY ARE NEEDED. + +-- GLH 7/2/85 + +WITH REPORT; USE REPORT; + +PROCEDURE C95093A IS +BEGIN + + TEST ("C95093A", "CHECK THAT THE DEFAULT EXPRESSION IS " & + "EVALUATED EACH TIME IT IS NEEDED"); + + DECLARE + + X : INTEGER := 1; + + FUNCTION F RETURN INTEGER IS + BEGIN + X := X + 1; + RETURN X; + END F; + + TASK T1 IS + ENTRY E1 (X, Y : INTEGER := F); + END T1; + + TASK BODY T1 IS + BEGIN + + ACCEPT E1 (X, Y : INTEGER := F) DO + IF X = Y OR Y /= 2 THEN + FAILED ("DEFAULT NOT EVALUATED CORRECTLY - " & + "1, X =" & INTEGER'IMAGE(X) & + ", Y =" & INTEGER'IMAGE(Y)); + END IF; + END E1; + + ACCEPT E1 (X, Y : INTEGER := F) DO + IF X = Y OR + NOT ((X = 3 AND Y = 4) OR + (X = 4 AND Y = 3)) THEN + FAILED ("DEFAULT NOT EVALUATED CORRECTLY - " & + "2, X =" & INTEGER'IMAGE(X) & + ", Y =" & INTEGER'IMAGE(Y)); + END IF; + END E1; + + END T1; + + BEGIN + + COMMENT ("FIRST CALL"); + T1.E1 (3); + + COMMENT ("SECOND CALL"); + T1.E1; + + END; + + RESULT; + +END C95093A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95095a.ada b/gcc/testsuite/ada/acats/tests/c9/c95095a.ada new file mode 100644 index 000000000..0cd02958d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95095a.ada @@ -0,0 +1,108 @@ +-- C95095A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT OVERLOADED SUBPROGRAM AND ENTRY DECLARATIONS +-- ARE PERMITTED IN WHICH THERE IS A MINIMAL +-- DIFFERENCE BETWEEN THE DECLARATIONS. + +-- (A) A FUNCTION AND AN ENTRY. + +-- JWC 7/24/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95095A IS + +BEGIN + TEST ("C95095A", "SUBPROGRAM/ENTRY OVERLOADING WITH " & + "MINIMAL DIFFERENCES"); + + -------------------------------------------------- + + -- BOTH PARAMETERIZED AND PARAMETERLESS SUBPROGRAMS AND ENTRIES + -- ARE TESTED. + + DECLARE + I, J, K : INTEGER := 0; + S : STRING (1..2) := "12"; + + TASK T IS + ENTRY E1 (I1, I2 : INTEGER); + ENTRY E2; + END T; + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E1 (I1, I2 : INTEGER) DO + S (1) := 'A'; + END E1; + OR + ACCEPT E2 DO + S (1) := 'C'; + END E2; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + + FUNCTION E1 (I1, I2 : INTEGER) RETURN INTEGER IS + BEGIN + S (2) := 'B'; + RETURN I1; -- RETURNED VALUE IS IRRELEVENT. + END E1; + + + FUNCTION E2 RETURN INTEGER IS + BEGIN + S (2) := 'D'; + RETURN I; -- RETURNED VALUE IS IRRELEVENT. + END E2; + + BEGIN + T.E1 (I, J); + K := E1 (I, J); + + IF S /= "AB" THEN + FAILED ("PARAMETERIZED OVERLOADED " & + "SUBPROGRAM AND ENTRY " & + "CAUSED CONFUSION"); + END IF; + + S := "12"; + T.E2; + K := E2; + + IF S /= "CD" THEN + FAILED ("PARAMETERLESS OVERLOADED " & + "SUBPROGRAM AND ENTRY " & + "CAUSED CONFUSION"); + END IF; + END; + + -------------------------------------------------- + + RESULT; +END C95095A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95095b.ada b/gcc/testsuite/ada/acats/tests/c9/c95095b.ada new file mode 100644 index 000000000..f3c9c0df5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95095b.ada @@ -0,0 +1,112 @@ +-- C95095B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT OVERLOADED ENTRY DECLARATIONS +-- ARE PERMITTED IN WHICH THERE IS A MINIMAL +-- DIFFERENCE BETWEEN THE DECLARATIONS. + +-- (B) ONE ENTRY HAS ONE LESS PARAMETER THAN THE OTHER. + +-- JWC 7/24/85 +-- JRK 10/2/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95095B IS + +BEGIN + TEST ("C95095B", "ENTRY OVERLOADING WITH " & + "MINIMAL DIFFERENCES"); + + -------------------------------------------------- + + -- ONE ENTRY HAS ONE MORE PARAMETER + -- THAN THE OTHER. THIS IS TESTED IN THE + -- CASE IN WHICH THAT PARAMETER HAS A DEFAULT + -- VALUE, AND THE CASE IN WHICH IT DOES NOT. + + DECLARE + I, J : INTEGER := 0; + B : BOOLEAN := TRUE; + S : STRING (1..2) := "12"; + + TASK T IS + ENTRY E1 (I1, I2 : INTEGER; B1 : IN OUT BOOLEAN); + ENTRY E1 (I1, I2 : INTEGER); + ENTRY E2 (B1 : IN OUT BOOLEAN; I1 : INTEGER := 0); + ENTRY E2 (B1 : IN OUT BOOLEAN); + END T; + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E1 (I1, I2 : INTEGER; + B1 : IN OUT BOOLEAN) DO + S (1) := 'A'; + END E1; + OR + ACCEPT E1 (I1, I2 : INTEGER) DO + S (2) := 'B'; + END E1; + OR + ACCEPT E2 (B1 : IN OUT BOOLEAN; + I1 : INTEGER := 0) DO + S (1) := 'C'; + END E2; + OR + ACCEPT E2 (B1 : IN OUT BOOLEAN) DO + S (2) := 'D'; + END E2; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + + BEGIN + T.E1 (I, J, B); + T.E1 (I, J); + + IF S /= "AB" THEN + FAILED ("ENTRIES DIFFERING ONLY IN " & + "NUMBER OF PARAMETERS (NO DEFAULTS) " & + "CAUSED CONFUSION"); + END IF; + + S := "12"; + T.E2 (B, I); + -- NOTE THAT A CALL TO T.E2 WITH ONLY + -- ONE PARAMETER IS AMBIGUOUS. + + IF S /= "C2" THEN + FAILED ("ENTRIES DIFFERING ONLY IN " & + "EXISTENCE OF ONE PARAMETER (WITH " & + "DEFAULT) CAUSED CONFUSION"); + END IF; + END; + + -------------------------------------------------- + + RESULT; +END C95095B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95095c.ada b/gcc/testsuite/ada/acats/tests/c9/c95095c.ada new file mode 100644 index 000000000..694c7d31e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95095c.ada @@ -0,0 +1,97 @@ +-- C95095C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT OVERLOADED ENTRY DECLARATIONS +-- ARE PERMITTED IN WHICH THERE IS A MINIMAL +-- DIFFERENCE BETWEEN THE DECLARATIONS. + +-- (C) THE BASE TYPE OF A PARAMETER IS DIFFERENT FROM THAT +-- OF THE CORRESPONDING ONE. + +-- JWC 7/24/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95095C IS + +BEGIN + TEST ("C95095C", "ENTRY OVERLOADING WITH " & + "MINIMAL DIFFERENCES"); + + -------------------------------------------------- + + -- THE BASE TYPE OF ONE PARAMETER IS + -- DIFFERENT FROM THAT OF THE CORRESPONDING + -- ONE. + + DECLARE + + TYPE NEWINT IS NEW INTEGER; + + I, J, K : INTEGER := 0; + N : NEWINT; + S : STRING (1..2) := "12"; + + TASK T IS + ENTRY E (I1 : INTEGER; N1 : OUT NEWINT; + I2 : IN OUT INTEGER); + ENTRY E (I1 : INTEGER; N1 : OUT INTEGER; + I2 : IN OUT INTEGER); + END T; + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E (I1 : INTEGER; N1 : OUT NEWINT; + I2 : IN OUT INTEGER) DO + S (1) := 'A'; + N1 := 0; -- THIS VALUE IS IRRELEVENT. + END E; + OR + ACCEPT E (I1 : INTEGER; N1 : OUT INTEGER; + I2 : IN OUT INTEGER) DO + S (2) := 'B'; + N1 := 0; -- THIS VALUE IS IRRELEVENT. + END E; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + + BEGIN + T.E (I, N, K); + T.E (I, J, K); + + IF S /= "AB" THEN + FAILED ("ENTRIES DIFFERING ONLY BY " & + "THE BASE TYPE OF A PARAMETER " & + "CAUSED CONFUSION"); + END IF; + END; + + -------------------------------------------------- + + RESULT; +END C95095C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95095d.ada b/gcc/testsuite/ada/acats/tests/c9/c95095d.ada new file mode 100644 index 000000000..f2ad7d95a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95095d.ada @@ -0,0 +1,99 @@ +-- C95095D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT OVERLOADED SUBPROGRAM AND ENTRY DECLARATIONS +-- ARE PERMITTED IN WHICH THERE IS A MINIMAL +-- DIFFERENCE BETWEEN THE DECLARATIONS. + +-- (D) A SUBPROGRAM IS DECLARED IN AN OUTER DECLARATIVE +-- PART, AN ENTRY IS DECLARED IN A TASK, AND THE +-- PARAMETERS ARE ORDERED DIFFERENTLY. + +-- JWC 7/24/85 +-- JRK 10/2/85 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C95095D IS + + +BEGIN + TEST ("C95095D", "SUBPROGRAM/ENTRY OVERLOADING WITH " & + "MINIMAL DIFFERENCES"); + + -------------------------------------------------- + + -- A SUBPROGRAM IS DECLARED IN AN OUTER DECLARATIVE + -- PART, AN ENTRY IS DECLARED IN A TASK, AND THE + -- PARAMETERS ARE ORDERED DIFFERENTLY. + + DECLARE + S : STRING (1..2) := "12"; + + I : INTEGER := 0; + + PROCEDURE E (I1 : INTEGER; I2 : IN OUT INTEGER; + B1 : BOOLEAN) IS + BEGIN + S (1) := 'A'; + END E; + + TASK T IS + ENTRY E (B1 : BOOLEAN; I1 : INTEGER; + I2 : IN OUT INTEGER); + END T; + + TASK BODY T IS + BEGIN + E (5, I, TRUE); -- PROCEDURE CALL. + ACCEPT E (B1 : BOOLEAN; I1 : INTEGER; + I2 : IN OUT INTEGER) DO + S (2) := 'B'; + END E; + E (TRUE, 5, I); -- ENTRY CALL; SELF-BLOCKING. + -- NOTE THAT A CALL IN WHICH ALL ACTUAL PARAMETERS + -- ARE NAMED_ASSOCIATIONS IS AMBIGUOUS. + FAILED ("TASK DID NOT BLOCK ITSELF"); + END T; + + BEGIN + + T.E (TRUE, 5, I); + + DELAY 10.0 * Impdef.One_Second; + ABORT T; + + IF S /= "AB" THEN + FAILED ("PROCEDURES/ENTRIES " & + "DIFFERING ONLY IN PARAMETER " & + "TYPE ORDER CAUSED CONFUSION"); + END IF; + END; + + -------------------------------------------------- + + RESULT; +END C95095D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c95095e.ada b/gcc/testsuite/ada/acats/tests/c9/c95095e.ada new file mode 100644 index 000000000..01951691f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c95095e.ada @@ -0,0 +1,88 @@ +-- C95095E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT OVERLOADED SUBPROGRAM AND ENTRY DECLARATIONS +-- ARE PERMITTED IN WHICH THERE IS A MINIMAL +-- DIFFERENCE BETWEEN THE DECLARATIONS. + +-- (E) A SUBPROGRAM IS DECLARED IN AN OUTER DECLARATIVE PART, +-- AN ENTRY IN A TASK, AND ONE HAS ONE MORE PARAMETER +-- THAN THE OTHER; THE OMITTED PARAMETER HAS A DEFAULT VALUE. + +-- JWC 7/30/85 +-- JRK 10/2/85 + +WITH REPORT; USE REPORT; +PROCEDURE C95095E IS + +BEGIN + TEST ("C95095E", "SUBPROGRAM/ENTRY OVERLOADING WITH " & + "MINIMAL DIFFERENCES ALLOWED"); + + -------------------------------------------------- + + -- A SUBPROGRAM IS IN AN OUTER DECLARATIVE + -- PART, AN ENTRY IN A TASK, AND ONE + -- HAS ONE MORE PARAMETER (WITH A DEFAULT + -- VALUE) THAN THE OTHER. + + DECLARE + S : STRING (1..3) := "123"; + + PROCEDURE E (I1, I2, I3 : INTEGER := 1) IS + C : CONSTANT STRING := "CXA"; + BEGIN + S (I3) := C (I3); + END E; + + TASK T IS + ENTRY E (I1, I2 : INTEGER := 1); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (I1, I2 : INTEGER := 1) DO + S (2) := 'B'; + END E; + END T; + + BEGIN + + E (1, 2, 3); + T.E (1, 2); + E (1, 2); + + IF S /= "CBA" THEN + FAILED ("PROCEDURES/ENTRIES DIFFERING " & + "ONLY IN EXISTENCE OF ONE " & + "DEFAULT-VALUED PARAMETER CAUSED " & + "CONFUSION"); + END IF; + + END; + + -------------------------------------------------- + + RESULT; +END C95095E; diff --git a/gcc/testsuite/ada/acats/tests/c9/c951001.a b/gcc/testsuite/ada/acats/tests/c9/c951001.a new file mode 100644 index 000000000..c1cf96593 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c951001.a @@ -0,0 +1,192 @@ +-- C951001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that two procedures in a protected object will not be +-- executed concurrently. +-- +-- TEST DESCRIPTION: +-- A very simple example of two tasks calling two procedures in the same +-- protected object is used. Test control code has been added to the +-- procedures such that, whichever gets called first executes a lengthy +-- calculation giving sufficient time (on a multiprocessor or a +-- time-slicing machine) for the other task to get control and call the +-- other procedure. The control code verifies that entry to the second +-- routine is postponed until the first is complete. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; +with ImpDef; + +procedure C951001 is + + protected Ramp_31 is + + procedure Add_Meter_Queue; + procedure Subtract_Meter_Queue; + function TC_Failed return Boolean; + + private + + Ramp_Count : integer range 0..20 := 4; -- Start test with some + -- vehicles on the ramp + + TC_Add_Started : Boolean := false; + TC_Subtract_Started : Boolean := false; + TC_Add_Finished : Boolean := false; + TC_Subtract_Finished : Boolean := false; + TC_Concurrent_Running: Boolean := false; + + end Ramp_31; + + + protected body Ramp_31 is + + function TC_Failed return Boolean is + begin + -- this indicator will have been set true if any instance + -- of concurrent running has been proved + return TC_Concurrent_Running; + end TC_Failed; + + + procedure Add_Meter_Queue is + begin + --================================================== + -- This section is all Test_Control code + TC_Add_Started := true; + if TC_Subtract_Started then + if not TC_Subtract_Finished then + TC_Concurrent_Running := true; + end if; + else + -- Subtract has not started. + -- Execute a lengthy routine to give it a chance to do so + ImpDef.Exceed_Time_Slice; + + if TC_Subtract_Started then + -- Subtract was able to start so we have concurrent + -- running and the test has failed + TC_Concurrent_Running := true; + end if; + end if; + TC_Add_Finished := true; + --================================================== + Ramp_Count := Ramp_Count + 1; + end Add_Meter_Queue; + + procedure Subtract_Meter_Queue is + begin + --================================================== + -- This section is all Test_Control code + TC_Subtract_Started := true; + if TC_Add_Started then + if not TC_Add_Finished then + -- We already have concurrent running + TC_Concurrent_Running := true; + end if; + else + -- Add has not started. + -- Execute a lengthy routine to give it a chance to do so + ImpDef.Exceed_Time_Slice; + + if TC_Add_Started then + -- Add was able to start so we have concurrent + -- running and the test has failed + TC_Concurrent_Running := true; + end if; + end if; + TC_Subtract_Finished := true; + --================================================== + Ramp_Count := Ramp_Count - 1; + end Subtract_Meter_Queue; + + end Ramp_31; + +begin + + Report.Test ("C951001", "Check that two procedures in a protected" & + " object will not be executed concurrently"); + + declare -- encapsulate the test + + task Vehicle_1; + task Vehicle_2; + + + -- Vehicle_1 and Vehicle_2 are simulations of Instances of the task + -- of type Vehicle in different stages of execution + + task body Vehicle_1 is + begin + null; -- ::::: stub. preparation code + + -- Add to the count of vehicles on the queue + Ramp_31.Add_Meter_Queue; + + null; -- ::::: stub: wait at the meter then pass to first sensor + + -- Reduce the count of vehicles on the queue + null; -- ::::: stub: Ramp_31.Subtract_Meter_Queue + exception + when others => + Report.Failed ("Unexpected Exception in Vehicle_1 task"); + end Vehicle_1; + + + task body Vehicle_2 is + begin + null; -- ::::: stub. preparation code + + -- Add to the count of vehicles on the queue + null; -- ::::: stub Ramp_31.Add_Meter_Queue; + + null; -- ::::: stub: wait at the meter then pass to first sensor + + -- Reduce the count of vehicles on the queue + Ramp_31.Subtract_Meter_Queue; + exception + when others => + Report.Failed ("Unexpected Exception in Vehicle_2 task"); + end Vehicle_2; + + + + begin + null; + end; -- encapsulation + + if Ramp_31.TC_Failed then + Report.Failed ("Concurrent Running detected"); + end if; + + Report.Result; + +end C951001; diff --git a/gcc/testsuite/ada/acats/tests/c9/c951002.a b/gcc/testsuite/ada/acats/tests/c9/c951002.a new file mode 100644 index 000000000..65b696c4a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c951002.a @@ -0,0 +1,334 @@ +-- C951002.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that an entry and a procedure within the same protected object +-- will not be executed simultaneously. +-- +-- TEST DESCRIPTION: +-- Two tasks are used. The first calls an entry who's barrier is set +-- and is thus queued. The second calls a procedure in the same +-- protected object. This procedure clears the entry barrier of the +-- first then executes a lengthy compute bound procedure. This is +-- intended to allow a multiprocessor, or a time-slicing implementation +-- of a uniprocessor, to (erroneously) permit the first task to continue +-- while the second is still computing. Flags in each process in the +-- PO are checked to ensure that they do not run out of sequence or in +-- parallel. +-- In the second part of the test another entry and procedure are used +-- but in this case the procedure is started first. A different task +-- calls the entry AFTER the procedure has started. If the entry +-- completes before the procedure the test fails. +-- +-- This test will not be effective on a uniprocessor without time-slicing +-- It is designed to increase the chances of failure on a multiprocessor, +-- or a uniprocessor with time-slicing, if the entry and procedure in a +-- Protected Object are not forced to acquire a single execution +-- resource. It is not guaranteed to fail. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; +with ImpDef; + +procedure C951002 is + + -- These global error flags are used for failure conditions within + -- the protected object. We cannot call Report.Failed (thus Text_io) + -- which would result in a bounded error. + -- + TC_Error_01 : Boolean := false; + TC_Error_02 : Boolean := false; + TC_Error_03 : Boolean := false; + TC_Error_04 : Boolean := false; + TC_Error_05 : Boolean := false; + TC_Error_06 : Boolean := false; + +begin + + Report.Test ("C951002", "Check that a procedure and an entry body " & + "in a protected object will not run concurrently"); + + declare -- encapsulate the test + + task Credit_Message is + entry TC_Start; + end Credit_Message; + + task Credit_Task is + entry TC_Start; + end Credit_Task; + + task Debit_Message is + entry TC_Start; + end Debit_Message; + + task Debit_Task is + entry TC_Start; + end Debit_Task; + + --==================================== + + protected Hold is + + entry Wait_for_CR_Underload; + procedure Clear_CR_Overload; + entry Wait_for_DB_Underload; + procedure Set_DB_Overload; + procedure Clear_DB_Overload; + -- + function TC_Message_is_Queued return Boolean; + + private + Credit_Overloaded : Boolean := true; -- Test starts in overload + Debit_Overloaded : Boolean := false; + -- + TC_CR_Proc_Finished : Boolean := false; + TC_CR_Entry_Finished : Boolean := false; + TC_DB_Proc_Finished : Boolean := false; + TC_DB_Entry_Finished : Boolean := false; + end Hold; + --==================== + protected body Hold is + + entry Wait_for_CR_Underload when not Credit_Overloaded is + begin + -- The barrier must only be re-evaluated at the end of the + -- of the execution of the procedure, also while the procedure + -- is executing this entry body must not be executed + if not TC_CR_Proc_Finished then + TC_Error_01 := true; -- Set error indicator + end if; + TC_CR_Entry_Finished := true; + end Wait_for_CR_Underload ; + + -- This is the procedure which should NOT be able to run in + -- parallel with the entry body + -- + procedure Clear_CR_Overload is + begin + + -- The entry body must not be executed until this procedure + -- is completed. + if TC_CR_Entry_Finished then + TC_Error_02 := true; -- Set error indicator + end if; + Credit_Overloaded := false; -- clear the entry barrier + + -- Execute an implementation defined compute bound routine which + -- is designed to run long enough to allow a task switch on a + -- time-sliced uniprocessor, or for a multiprocessor to pick up + -- another task. + -- + ImpDef.Exceed_Time_Slice; + + -- Again, the entry body must not be executed until the current + -- procedure is completed. + -- + if TC_CR_Entry_Finished then + TC_Error_03 := true; -- Set error indicator + end if; + TC_CR_Proc_Finished := true; + + end Clear_CR_Overload; + + --============ + -- The following subprogram and entry body are used in the second + -- part of the test + + entry Wait_for_DB_Underload when not Debit_Overloaded is + begin + -- By the time the task that calls this entry is allowed access to + -- the queue the barrier, which starts off as open, will be closed + -- by the Set_DB_Overload procedure. It is only reopened + -- at the end of the test + if not TC_DB_Proc_Finished then + TC_Error_04 := true; -- Set error indicator + end if; + TC_DB_Entry_Finished := true; + end Wait_for_DB_Underload ; + + + procedure Set_DB_Overload is + begin + -- The task timing is such that this procedure should be started + -- before the entry is called. Thus the entry should be blocked + -- until the end of this procedure which then sets the barrier + -- + if TC_DB_Entry_Finished then + TC_Error_05 := true; -- Set error indicator + end if; + + -- Execute an implementation defined compute bound routine which + -- is designed to run long enough to allow a task switch on a + -- time-sliced uniprocessor, or for a multiprocessor to pick up + -- another task + -- + ImpDef.Exceed_Time_Slice; + + Debit_Overloaded := true; -- set the entry barrier + + if TC_DB_Entry_Finished then + TC_Error_06 := true; -- Set error indicator + end if; + TC_DB_Proc_Finished := true; + + end Set_DB_Overload; + + procedure Clear_DB_Overload is + begin + Debit_Overloaded := false; -- open the entry barrier + end Clear_DB_Overload; + + function TC_Message_is_Queued return Boolean is + begin + + -- returns true when one message arrives on the queue + return (Wait_for_CR_Underload'Count = 1); + + end TC_Message_is_Queued ; + + end Hold; + + --==================================== + + task body Credit_Message is + begin + accept TC_Start; + --:: some application processing. Part of the process finds that + -- the Overload threshold has been exceeded for the Credit + -- application. This message task queues itself on a queue + -- waiting till the overload in no longer in effect + Hold.Wait_for_CR_Underload; + exception + when others => + Report.Failed ("Unexpected Exception in Credit_Message Task"); + end Credit_Message; + + task body Credit_Task is + begin + accept TC_Start; + -- Application code here (not shown) determines that the + -- underload threshold has been reached + Hold.Clear_CR_Overload; + exception + when others => + Report.Failed ("Unexpected Exception in Credit_Task"); + end Credit_Task; + + --============== + + -- The following two tasks are used in the second part of the test + + task body Debit_Message is + begin + accept TC_Start; + --:: some application processing. Part of the process finds that + -- the Overload threshold has been exceeded for the Debit + -- application. This message task queues itself on a queue + -- waiting till the overload is no longer in effect + -- + Hold.Wait_for_DB_Underload; + exception + when others => + Report.Failed ("Unexpected Exception in Debit_Message Task"); + end Debit_Message; + + task body Debit_Task is + begin + accept TC_Start; + -- Application code here (not shown) determines that the + -- underload threshold has been reached + Hold.Set_DB_Overload; + exception + when others => + Report.Failed ("Unexpected Exception in Debit_Task"); + end Debit_Task; + + begin -- declare + + Credit_Message.TC_Start; + + -- Wait until the message is queued on the entry before starting + -- the Credit_Task + while not Hold.TC_Message_is_Queued loop + delay ImpDef.Long_Minimum_Task_Switch; + end loop; + -- + Credit_Task.TC_Start; + + -- Ensure the first part of the test is complete before continuing + while not (Credit_Message'terminated and Credit_Task'terminated) loop + delay ImpDef.Long_Minimum_Task_Switch; + end loop; + + --====================================================== + -- Second part of the test + + + Debit_Task.TC_Start; + + -- Delay long enough to allow a task switch to the Debit_Task and + -- for it to reach the accept statement and call Hold.Set_DB_Overload + -- before starting Debit_Message + -- + delay ImpDef.Long_Switch_To_New_Task; + + Debit_Message.TC_Start; + + while not Debit_Task'terminated loop + delay ImpDef.Long_Minimum_Task_Switch; + end loop; + + Hold.Clear_DB_Overload; -- Allow completion + + end; -- declare (encapsulation) + + if TC_Error_01 then + Report.Failed ("Wait_for_CR_Underload executed out of sequence"); + end if; + if TC_Error_02 then + Report.Failed ("Credit: Entry executed before procedure"); + end if; + if TC_Error_03 then + Report.Failed ("Credit: Entry executed in parallel"); + end if; + if TC_Error_04 then + Report.Failed ("Wait_for_DB_Underload executed out of sequence"); + end if; + if TC_Error_05 then + Report.Failed ("Debit: Entry executed before procedure"); + end if; + if TC_Error_06 then + Report.Failed ("Debit: Entry executed in parallel"); + end if; + + Report.Result; + +end C951002; diff --git a/gcc/testsuite/ada/acats/tests/c9/c953001.a b/gcc/testsuite/ada/acats/tests/c9/c953001.a new file mode 100644 index 000000000..bc9c85f30 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c953001.a @@ -0,0 +1,188 @@ +-- C953001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that if the evaluation of an entry_barrier condition +-- propagates an exception, the exception Program_Error +-- is propagated to all current callers of all entries of the +-- protected object. +-- +-- TEST DESCRIPTION: +-- This test declares a protected object (PO) with two entries and +-- a 5 element entry family. +-- All the entries are always closed. However, one of the entries +-- (Oh_No) will get a constraint_error in its barrier_evaluation +-- whenever the global variable Blow_Up is true. +-- An array of tasks is created where the tasks wait on the various +-- entries of the protected object. Once all the tasks are waiting +-- the main procedure calls the entry Oh_No and causes an exception +-- to be propagated to all the tasks. The tasks record the fact +-- that they got the correct exception in global variables that +-- can be checked after the tasks complete. +-- +-- +-- CHANGE HISTORY: +-- 19 OCT 95 SAIC ACVC 2.1 +-- +--! + + +with Report; +with ImpDef; +procedure C953001 is + Verbose : constant Boolean := False; + Max_Tasks : constant := 12; + + -- note status and error conditions + Blocked_Entry_Taken : Boolean := False; + In_Oh_No : Boolean := False; + Task_Passed : array (1..Max_Tasks) of Boolean := (1..Max_Tasks => False); + +begin + Report.Test ("C953001", + "Check that an exception in an entry_barrier condition" & + " causes Program_Error to be propagated to all current" & + " callers of all entries of the protected object"); + + declare -- test encapsulation + -- miscellaneous values + Cows : Integer := Report.Ident_Int (1); + Came_Home : Integer := Report.Ident_Int (2); + + -- make the Barrier_Condition fail only when we want it to + Blow_Up : Boolean := False; + + function Barrier_Condition return Boolean is + begin + if Blow_Up then + return 5 mod Report.Ident_Int(0) = 1; + else + return False; + end if; + end Barrier_Condition; + + subtype Family_Index is Integer range 1..5; + + protected PO is + entry Block1; + entry Oh_No; + entry Family (Family_Index); + end PO; + + protected body PO is + entry Block1 when Report.Ident_Int(0) = Report.Ident_Int(1) is + begin + Blocked_Entry_Taken := True; + end Block1; + + -- barrier will get a Constraint_Error (divide by 0) + entry Oh_No when Barrier_Condition is + begin + In_Oh_No := True; + end Oh_No; + + entry Family (for Member in Family_Index) when Cows = Came_Home is + begin + Blocked_Entry_Taken := True; + end Family; + end PO; + + + task type Waiter is + entry Take_Id (Id : Integer); + end Waiter; + + Bunch_of_Waiters : array (1..Max_Tasks) of Waiter; + + task body Waiter is + Me : Integer; + Action : Integer; + begin + accept Take_Id (Id : Integer) do + Me := Id; + end Take_Id; + + Action := Me mod (Family_Index'Last + 1); + begin + if Action = 0 then + PO.Block1; + else + PO.Family (Action); + end if; + Report.Failed ("no exception for task" & Integer'Image (Me)); + exception + when Program_Error => + Task_Passed (Me) := True; + if Verbose then + Report.Comment ("pass for task" & Integer'Image (Me)); + end if; + when others => + Report.Failed ("wrong exception raised in task" & + Integer'Image (Me)); + end; + end Waiter; + + + begin -- test encapsulation + for I in 1..Max_Tasks loop + Bunch_Of_Waiters(I).Take_Id (I); + end loop; + + -- give all the Waiters time to get queued + delay 2*ImpDef.Clear_Ready_Queue; + + -- cause the protected object to fail + begin + Blow_Up := True; + PO.Oh_No; + Report.Failed ("no exception in call to PO.Oh_No"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error instead of Program_Error"); + when Program_Error => + if Verbose then + Report.Comment ("main exception passed"); + end if; + when others => + Report.Failed ("wrong exception in main"); + end; + end; -- test encapsulation + + -- all the tasks have now completed. + -- check the flags for pass/fail info + if Blocked_Entry_Taken then + Report.Failed ("blocked entry taken"); + end if; + if In_Oh_No then + Report.Failed ("entry taken with exception in barrier"); + end if; + for I in 1..Max_Tasks loop + if not Task_Passed (I) then + Report.Failed ("task" & Integer'Image (I) & " did not pass"); + end if; + end loop; + + Report.Result; +end C953001; diff --git a/gcc/testsuite/ada/acats/tests/c9/c953002.a b/gcc/testsuite/ada/acats/tests/c9/c953002.a new file mode 100644 index 000000000..d821bb24e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c953002.a @@ -0,0 +1,242 @@ +-- C953002.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the servicing of entry queues of a protected object +-- continues until there are no open entries with queued calls +-- and that this takes place as part of a single protected +-- operation. +-- +-- TEST DESCRIPTION: +-- This test enqueues a bunch of tasks on the entries of the +-- protected object Main_PO. At the same time another bunch of +-- of tasks are queued on the single entry of protected object +-- Holding_Pen. +-- Once all the tasks have had time to block, the main procedure +-- opens all the entries for Main_PO by calling the +-- Start_Protected_Operation protected procedure. This should +-- process all the pending callers as part of a single protected +-- operation. +-- During this protected operation, the entries of Main_PO release +-- the tasks blocked on Holding_Pen by calling the protected +-- procedure Release. +-- Once released from Holding_Pen, the task immediately calls +-- an entry in Main_PO. +-- These new calls should not gain access to Main_PO until +-- the initial protected operation on that object completes. +-- The order in which the entry calls on Main_PO are taken is +-- recorded in a global array and checked after all the tasks +-- have terminated. +-- +-- +-- CHANGE HISTORY: +-- 25 OCT 95 SAIC ACVC 2.1 +-- 15 JAN 95 SAIC Fixed deadlock problem. +-- +--! + +with Report; +procedure C953002 is + Verbose : constant Boolean := False; + + Half_Tasks : constant := 15; -- how many tasks of each group + Max_Tasks : constant := Half_Tasks * 2; -- total number of tasks + + Note_Order : array (1..Max_Tasks) of Integer := (1..Max_Tasks => 0); + Note_Cnt : Integer := 0; +begin + Report.Test ("C953002", + "Check that the servicing of entry queues handles all" & + " open entries as part of a single protected operation"); + declare + task type Assault_PO is + entry Take_ID (Id : Integer); + end Assault_PO; + + First_Wave : array (1 .. Half_Tasks) of Assault_PO; + Second_Wave : array (1 .. Half_Tasks) of Assault_PO; + + protected Main_PO is + entry E0 (Who : Integer); + entry E1 (Who : Integer); + entry E2 (Who : Integer); + entry E3 (Who : Integer); + entry All_Present; + procedure Start_Protected_Operation; + private + Open : Boolean := False; + end Main_PO; + + protected Holding_Pen is + -- Note that Release is called by tasks executing in + -- the protected object Main_PO. + entry Wait (Who : Integer); + entry All_Present; + procedure Release; + private + Open : Boolean := False; + end Holding_Pen; + + + protected body Main_PO is + procedure Start_Protected_Operation is + begin + Open := True; + -- at this point all the First_Wave tasks are + -- waiting at the entries and all of them should + -- be processed as part of the protected operation. + end Start_Protected_Operation; + + entry All_Present when E0'Count + E1'Count + E2'Count + E3'Count = + Max_Tasks / 2 is + begin + null; -- all tasks are waiting + end All_Present; + + entry E0 (Who : Integer) when Open is + begin + Holding_Pen.Release; + -- note the order in which entry calls are handled. + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + end E0; + + entry E1 (Who : Integer) when Open is + begin + Holding_Pen.Release; + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + end E1; + + entry E2 (Who : Integer) when Open is + begin + Holding_Pen.Release; + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + end E2; + + entry E3 (Who : Integer) when Open is + begin + Holding_Pen.Release; + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + end E3; + end Main_PO; + + + protected body Holding_Pen is + procedure Release is + begin + Open := True; + end Release; + + entry All_Present when Wait'Count = Max_Tasks / 2 is + begin + null; -- all tasks waiting + end All_Present; + + entry Wait (Who : Integer) when Open is + begin + null; -- unblock the task + end Wait; + end Holding_Pen; + + task body Assault_PO is + Me : Integer; + begin + accept Take_Id (Id : Integer) do + Me := Id; + end Take_Id; + if Me >= 200 then + Holding_Pen.Wait (Me); + end if; + case Me mod 4 is + when 0 => Main_PO.E0 (Me); + when 1 => Main_PO.E1 (Me); + when 2 => Main_PO.E2 (Me); + when 3 => Main_PO.E3 (Me); + when others => null; -- cant happen + end case; + if Verbose then + Report.Comment ("task" & Integer'Image (Me) & + " done"); + end if; + exception + when others => + Report.Failed ("exception in task"); + end Assault_PO; + + begin -- test encapsulation + for I in First_Wave'Range loop + First_Wave (I).Take_ID (100 + I); + end loop; + for I in Second_Wave'Range loop + Second_Wave (I).Take_ID (200 + I); + end loop; + + -- let all the tasks get blocked + Main_PO.All_Present; + Holding_Pen.All_Present; + + -- let the games begin + if Verbose then + Report.Comment ("starting protected operation"); + end if; + Main_PO.Start_Protected_Operation; + + -- wait for all the tasks to complete + if Verbose then + Report.Comment ("waiting for tasks to complete"); + end if; + end; + + -- make sure all tasks registered their order + if Note_Cnt /= Max_Tasks then + Report.Failed ("task registration count wrong. " & + Integer'Image (Note_Cnt)); + end if; + + -- check the order in which entries were handled. + -- all the 100 level items should be handled as part of the + -- first protected operation and thus should be completed + -- before any 200 level item. + + if Verbose then + for I in 1..Max_Tasks loop + Report.Comment ("order" & Integer'Image (I) & " is" & + Integer'Image (Note_Order (I))); + end loop; + end if; + for I in 2 .. Max_Tasks loop + if Note_Order (I) < 200 and + Note_Order (I-1) >= 200 then + Report.Failed ("protected operation failure" & + Integer'Image (Note_Order (I-1)) & + Integer'Image (Note_Order (I))); + end if; + end loop; + + Report.Result; +end C953002; diff --git a/gcc/testsuite/ada/acats/tests/c9/c953003.a b/gcc/testsuite/ada/acats/tests/c9/c953003.a new file mode 100644 index 000000000..4ac91169e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c953003.a @@ -0,0 +1,189 @@ +-- C953003.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the servicing of entry queues of a protected object +-- continues until there are no open entries with queued (or +-- requeued) calls and that internal requeues are handled +-- as part of a single protected operation. +-- +-- TEST DESCRIPTION: +-- A number of tasks are created and blocked on a protected object +-- so that they can all be released at one time. When released, +-- these tasks make an entry call to an entry in the Main_PO +-- protected object. As part of the servicing of this entry +-- call the call is passed through the remaining entries of the +-- protected object by using internal requeues. The protected +-- object checks that no other entry call is accepted until +-- after all the internal requeuing has completed. +-- +-- +-- CHANGE HISTORY: +-- 12 JAN 96 SAIC Initial version for 2.1 +-- +--! + +with Report; +procedure C953003 is + Verbose : constant Boolean := False; + + Order_Error : Boolean := False; + + Max_Tasks : constant := 10; -- total number of tasks + Max_Entries : constant := 4; -- number of entries in Main_PO + Note_Cnt : Integer := 0; + Note_Order : array (1..Max_Tasks*Max_Entries) of Integer; +begin + Report.Test ("C953003", + "Check that the servicing of entry queues handles all" & + " open entries as part of a single protected operation," & + " including those resulting from an internal requeue"); + declare + task type Assault_PO is + entry Take_ID (Id : Integer); + end Assault_PO; + + Marines : array (1 .. Max_Tasks) of Assault_PO; + + protected Main_PO is + entry E0 (Who : Integer); + private + entry E3 (Who : Integer); + entry E2 (Who : Integer); + entry E1 (Who : Integer); + Expected_Next : Integer := 0; + end Main_PO; + + + protected body Main_PO is + + entry E0 (Who : Integer) when True is + begin + Order_Error := Order_Error or Expected_Next /= 0; + Expected_Next := 1; + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + requeue E1; + end E0; + + entry E1 (Who : Integer) when True is + begin + Order_Error := Order_Error or Expected_Next /= 1; + Expected_Next := 2; + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + requeue E2; + end E1; + + entry E3 (Who : Integer) when True is + begin + Order_Error := Order_Error or Expected_Next /= 3; + Expected_Next := 0; + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + -- all done - return now + end E3; + + entry E2 (Who : Integer) when True is + begin + Order_Error := Order_Error or Expected_Next /= 2; + Expected_Next := 3; + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + requeue E3; + end E2; + end Main_PO; + + protected Holding_Pen is + entry Wait_For_All_Present; + entry Wait; + private + Open : Boolean := False; + end Holding_Pen; + + protected body Holding_Pen is + entry Wait_For_All_Present when Wait'Count = Max_Tasks is + begin + Open := True; + end Wait_For_All_Present; + + entry Wait when Open is + begin + null; -- just go + end Wait; + end Holding_Pen; + + + task body Assault_PO is + Me : Integer; + begin + accept Take_Id (Id : Integer) do + Me := Id; + end Take_Id; + Holding_Pen.Wait; + Main_PO.E0 (Me); + if Verbose then + Report.Comment ("task" & Integer'Image (Me) & + " done"); + end if; + exception + when others => + Report.Failed ("exception in task"); + end Assault_PO; + + begin -- test encapsulation + for I in Marines'Range loop + Marines (I).Take_ID (100 + I); + end loop; + + -- let all the tasks get blocked so we can release them all + -- at one time + Holding_Pen.Wait_For_All_Present; + + -- wait for all the tasks to complete + if Verbose then + Report.Comment ("waiting for tasks to complete"); + end if; + end; + + -- make sure all tasks registered their order + if Note_Cnt /= Max_Tasks * Max_Entries then + Report.Failed ("task registration count wrong. " & + Integer'Image (Note_Cnt)); + end if; + + if Order_Error then + Report.Failed ("internal requeue not handled as part of operation"); + end if; + + if Verbose or Order_Error then + for I in 1..Max_Tasks * Max_Entries loop + Report.Comment ("order" & Integer'Image (I) & " is" & + Integer'Image (Note_Order (I))); + end loop; + end if; + + Report.Result; +end C953003; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954001.a b/gcc/testsuite/ada/acats/tests/c9/c954001.a new file mode 100644 index 000000000..3112cce2b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954001.a @@ -0,0 +1,273 @@ +-- C954001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a requeue statement within an entry_body with parameters +-- may requeue the entry call to a protected entry with a subtype- +-- conformant parameter profile. Check that, if the call is queued on the +-- new entry's queue, the original caller remains blocked after the +-- requeue, but the entry_body containing the requeue is completed. +-- +-- TEST DESCRIPTION: +-- Declare a protected object which simulates a disk device. Declare an +-- entry that requeues the caller to a second entry if the disk head is +-- not in the proper location, but first sets the second entry's barrier +-- to false. Declare a procedure which sets the second entry's barrier +-- to true. +-- +-- Declare a task which calls the first entry such that the requeue is +-- called. This task should be queued on the second entry and remain +-- blocked, and the first entry should be complete. Call the procedure +-- which releases the second entry's queue. The second entry should +-- complete, after which the task should complete. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package C954001_0 is -- Disk management abstraction. + + + -- Simulate a read-only disk device with a head that may be moved to + -- different tracks. If a read request is issued for the current + -- track, the request can be satisfied immediately. Otherwise, the head + -- must be moved to the correct track, during which time the calling task + -- is blocked. When the head reaches the correct track, the disk generates + -- an interrupt, after which the request can be satisfied, and the + -- calling task can proceed. + + Buffer_Size : constant := 100; + + type Disk_Buffer is new String (1 .. Buffer_Size); + type Disk_Track is new Natural; + + type Disk_Address is record + Track : Disk_Track; + -- Additional components. + end record; + + Initial_Track : constant Disk_Track := 0; + New_Track : constant Disk_Track := 5; + + --==============================================-- + + protected Disk_Device is + + entry Read (Where : Disk_Address; -- Read data from disk + Data : out Disk_Buffer); -- track. + + procedure Disk_Interrupt; -- Handle interrupt + -- from disk. + + function TC_Track return Disk_Track; -- Return current track. + + function TC_Pending_Queued return Boolean; -- True when there is + -- an entry in queue + + private + + entry Pending_Read (Where : Disk_Address; -- Wait for head to + Data : out Disk_Buffer); -- move then read data. + + Current_Track : Disk_Track := Initial_Track; -- Current disk track. + Operation_Pending : Boolean := False; -- Vis. entry barrier. + Disk_Interrupted : Boolean := False; -- Priv. entry barrier. + + end Disk_Device; + + +end C954001_0; + + + --==================================================================-- + + +package body C954001_0 is -- Disk management abstraction. + + + protected body Disk_Device is + + entry Read (Where : Disk_Address; Data : out Disk_Buffer) + when not Operation_Pending is + begin + if (Where.Track = Current_Track) then -- If the head is over the + -- Read data from disk... -- requested track, read + null; -- the data. + + else -- Otherwise, defer read + Operation_Pending := True; -- while head is moved to + -- correct track (signaled + -- -- -- by a disk interrupt). + -- Requeue is tested here -- + -- -- + + requeue Pending_Read; + + end if; + end Read; + + + procedure Disk_Interrupt is -- Called when the disk + begin -- interrupts, indicating + Disk_Interrupted := True; -- that the head is over + end Disk_Interrupt; -- the correct track. + + + function TC_Track return Disk_Track is -- Artifice required for + begin -- testing purposes. + return (Current_Track); + end TC_Track; + + + entry Pending_Read (Where : Disk_Address; Data : out Disk_Buffer) + when Disk_Interrupted is + begin + Current_Track := Where.Track; -- Head is now over the + -- Read data from disk... -- correct track; read + Operation_Pending := False; -- the data. + Disk_Interrupted := False; + end Pending_Read; + + function TC_Pending_Queued return Boolean is + begin + -- Return true when there is something on the Pending_Read queue + return (Pending_Read'Count /=0); + end TC_Pending_Queued; + + end Disk_Device; + + +end C954001_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +with C954001_0; -- Disk management abstraction. +use C954001_0; + +procedure C954001 is + + + task type Read_Task is -- an unusual (but legal) declaration + end Read_Task; + -- + -- + task body Read_Task is + Location : constant Disk_Address := (Track => New_Track); + Data : Disk_Buffer := (others => ' '); + begin + Disk_Device.Read (Location, Data); -- Invoke requeue statement. + exception + when others => + Report.Failed ("Exception raised in task"); + end Read_Task; + + --==============================================-- + +begin -- Main program. + + Report.Test ("C954001", "Requeue from an entry within a P.O. " & + "to a private entry within the same P.O."); + + + declare + + IO_Request : Read_Task; -- Request a read from other + -- than the current track. + -- IO_Request will be requeued + -- from Read to Pending_Read. + begin + + -- To pass this test, the following must be true: + -- + -- (A) The Read entry call made by the task IO_Request must be + -- completed by the requeue. + -- (B) IO_Request must remain blocked following the requeue. + -- (C) IO_Request must be queued on the Pending_Read entry queue. + -- (D) IO_Request must continue execution after the Pending_Read + -- entry completes. + -- + -- First, verify (A): that the Read entry call is complete. + -- + -- Call a protected operation (Disk_Device.TC_Track). Since no two + -- protected actions may proceed concurrently unless both are protected + -- function calls, a call to a protected operation at this point can + -- proceed only if the Read entry call is already complete. + -- + -- Note that if Read is NOT complete, the test will likely hang here. + -- + -- Next, verify (B): that IO_Request remains blocked following the + -- requeue. Also verify that Pending_Read (the entry to which + -- IO_Request should have been queued) has not yet executed. + + -- Wait until the task had made the call and the requeue has been + -- effected. + while not Disk_Device.TC_Pending_Queued loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + if Disk_Device.TC_Track /= Initial_Track then + Report.Failed ("Target entry of requeue executed prematurely"); + elsif IO_Request'Terminated then + Report.Failed ("Caller did not remain blocked after " & + "the requeue or was never requeued"); + else + + -- Verify (C): that IO_Request is queued on the + -- Pending_Read entry queue. + -- + -- Set the barrier for Pending_Read to true. Check that the + -- current track is updated and that IO_Request terminates. + + Disk_Device.Disk_Interrupt; -- Simulate a disk interrupt, + -- signaling that the head is + -- over the correct track. + + -- The Pending_Read entry body will complete before the next + -- protected action is called (Disk_Device.TC_Track). + + if Disk_Device.TC_Track /= New_Track then + Report.Failed ("Caller was not requeued on target entry"); + end if; + + -- Finally, verify (D): that Read_Task continues after Pending_Read + -- completes. + -- + -- Note that the test will hang here if Read_Task does not continue + -- executing following the completion of the requeued entry call. + + end if; + + end; -- We will not exit the declare block until the task completes + + Report.Result; + +end C954001; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954010.a b/gcc/testsuite/ada/acats/tests/c9/c954010.a new file mode 100644 index 000000000..ac39c89a8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954010.a @@ -0,0 +1,286 @@ +-- C954010.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a requeue within an accept statement does not block. +-- This test uses: Requeue to an entry in a different task +-- Parameterless call +-- Requeue with abort +-- +-- TEST DESCRIPTION: +-- In the Distributor task, requeue two successive calls on the entries +-- of two separate target tasks. Verify that the target tasks are +-- run in parallel proving that the first requeue does not block +-- while the first target rendezvous takes place. +-- +-- This series of tests uses a simulation of a transaction driven +-- processing system. Line Drivers accept input from an external source +-- and build them into transaction records. These records are then +-- encapsulated in message tasks which remain extant for the life of the +-- transaction in the system. The message tasks put themselves on the +-- input queue of a Distributor which, from information in the +-- transaction and/or system load conditions forwards them to other +-- operating tasks. These in turn might forward the transactions to yet +-- other tasks for further action. The routing is, in real life, +-- dynamic and unpredictable at the time of message generation. All +-- rerouting in this model is done by means of requeues. +-- +-- This test is directed towards the BLOCKING of the REQUEUE only +-- If the original caller does not block, the outcome of the test will +-- not be affected. If the original caller does not continue after +-- the return, the test will not pass. +-- If the requeue gets placed on the wrong entry a failing test could +-- pass (eg. if the first message is delivered to the second +-- computation task and the second message to the first) - a check for +-- this condition is made in other tests +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; +with ImpDef; + +procedure C954010 is + + -- Mechanism to count the number of Message tasks completed + protected TC_Tasks_Completed is + procedure Increment; + function Count return integer; + private + Number_Complete : integer := 0; + end TC_Tasks_Completed; + -- + TC_Expected_To_Complete : constant integer := 2; + + + task type Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + task Distributor is + entry Input; + end Distributor; + + task Credit_Computation is + entry Input; + end Credit_Computation; + + task Debit_Computation is + entry Input; + entry TC_Artificial_Rendezvous_1; -- test purposes only + entry TC_Artificial_Rendezvous_2; -- test purposes only + end Debit_Computation; + + + -- Mechanism to count the number of Message tasks completed + protected body TC_Tasks_Completed is + procedure Increment is + begin + Number_Complete := Number_Complete + 1; + end Increment; + + function Count return integer is + begin + return Number_Complete; + end Count; + end TC_Tasks_Completed; + + + + -- Assemble messages received from an external source + -- Creates a message task for each and sends this to a Distributor + -- for appropriate disposal around the network of tasks + -- Such a task would normally be designed to loop continuously + -- creating the messages as input is received. Simulate this + -- but limit it to two dummy messages for this test and allow it + -- to terminate at that point + -- + task body Line_Driver is + + begin + + accept Start; -- Wait for trigger from main + + for i in 1..2 loop + declare + -- create a new message task + N : acc_Message_Task := new Message_Task; + begin + -- preparation code + null; -- stub + + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + task body Message_Task is + begin + -- Queue up on Distributor's Input queue + Distributor.Input; + + -- After the required computations have been performed + -- return the message appropriately (probably to an output + -- line driver + null; -- stub + + -- Increment to show completion of this task + TC_Tasks_Completed.Increment; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + -- Dispose each input message to the appropriate computation tasks + -- Normally this would be according to some parameters in the entry + -- but this simple test is using parameterless entries. + -- + task body Distributor is + Last_was_for_Credit_Computation : Boolean := false; -- switch + begin + loop + select + accept Input do + -- Determine to which task the message should be + -- distributed + -- For this test arbitrarily send the first to + -- Credit_Computation and the second to Debit_Computation + if Last_was_for_Credit_Computation then + requeue Debit_Computation.Input with abort; + else + Last_was_for_Credit_Computation := true; + requeue Credit_Computation.Input with abort; + end if; + end Input; + or + terminate; + end select; + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Distributor"); + end Distributor; + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + task body Credit_Computation is + begin + loop + select + accept Input do + -- Perform the computations required for this message + -- + null; -- stub + + -- For the test: + -- Artificially rendezvous with Debit_Computation. + -- If the first requeue in Distributor has blocked + -- waiting for the current rendezvous to complete then the + -- second message will not be sent to Debit_Computation + -- which will still be waiting on its Input accept. + -- This task will HANG + -- + Debit_Computation.TC_Artificial_Rendezvous_1; + -- + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + task body Debit_Computation is + Message_Count : integer := 0; + TC_AR1_is_complete : Boolean := false; + begin + loop + select + accept Input do + -- Perform the computations required for this message + null; -- stub + end Input; + Message_Count := Message_Count + 1; + or + -- Guard until the rendezvous with the message for this task + -- has completed + when Message_Count > 0 => + accept TC_Artificial_Rendezvous_1; -- see comments in + -- Credit_Computation above + TC_AR1_is_complete := true; + or + -- Completion rendezvous with the main procedure + when TC_AR1_is_complete => + accept TC_Artificial_Rendezvous_2; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + + end Debit_Computation; + + +begin -- c954010 + Report.Test ("C954010", "Requeue in an accept body does not block"); + + Line_Driver.Start; + + -- Ensure that both messages were delivered to the computation tasks + -- This shows that both requeues were effective. + -- + Debit_Computation.TC_Artificial_Rendezvous_2; + + -- Ensure that the message tasks completed + while (TC_Tasks_Completed.Count < TC_Expected_To_Complete) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + +end C954010; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954011.a b/gcc/testsuite/ada/acats/tests/c9/c954011.a new file mode 100644 index 000000000..159b32dba --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954011.a @@ -0,0 +1,384 @@ +-- C954011.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a requeue is placed on the correct entry; that the +-- original caller waits for the completion of the requeued rendezvous; +-- that the original caller continues after the rendezvous. +-- Specifically, this test checks requeue to an entry in a different +-- task, requeue where the entry has parameters, and requeue with +-- abort. +-- +-- TEST DESCRIPTION: +-- In the Distributor task, requeue two successive calls on the entries +-- of two separate target tasks. Each task in each of the paths adds +-- identifying information in the transaction being passed. This +-- information is checked by the Message tasks on completion ensuring that +-- the requeues have been placed on the correct queues. +-- +-- This series of tests uses a simulation of a transaction driven +-- processing system. Line Drivers accept input from an external source +-- and build them into transaction records. These records are then +-- encapsulated in message tasks which remain extant for the life of the +-- transaction in the system. The message tasks put themselves on the +-- input queue of a Distributor which, from information in the +-- transaction and/or system load conditions forwards them to other +-- operating tasks. These in turn might forward the transactions to yet +-- other tasks for further action. The routing is, in real life, +-- dynamic and unpredictable at the time of message generation. All +-- rerouting in this model is done by means of requeues. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 26 Nov 95 SAIC Fixed problems with shared global variables +-- for ACVC 2.0.1 +-- +--! + +with Report; +with ImpDef; + +procedure C954011 is + + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + type Transaction_Code is (Credit, Debit); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Distrib : Boolean := false; + end record; + + protected type Message_Mgr is + procedure Mark_Complete; + function Is_Complete return Boolean; + private + Complete : Boolean := False; + end Message_Mgr; + + protected body Message_Mgr is + procedure Mark_Complete is + begin + Complete := True; + end Mark_Complete; + + Function Is_Complete return Boolean is + begin + return Complete; + end Is_Complete; + end Message_Mgr; + + TC_Debit_Message : Message_Mgr; + TC_Credit_Message : Message_Mgr; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + task Distributor is + entry Input(Transaction : acc_Transaction_Record); + end Distributor; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- The Line Driver task would normally be designed to loop continuously + -- creating the messages as input is received. Simulate this + -- but limit it to two dummy messages for this test and allow it + -- to terminate at that point + -- + task body Line_Driver is + Current_ID : integer := 1; + TC_Last_was_for_credit : Boolean := false; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + accept Start; -- Wait for trigger from Main + + for i in 1..2 loop -- arbitrarily limit to two messages for the test + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record + := new Transaction_Record; + begin + if TC_Last_was_for_credit then + Build_Debit_Record ( Next_Transaction ); + else + Build_Credit_Record( Next_Transaction ); + TC_Last_was_for_credit := true; + end if; + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + + -- The following is all Test Control Code + + -- Check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= Credit_Return or + This_Transaction.TC_Message_Count /= 1 or not + This_Transaction.TC_Thru_Distrib then + Report.Failed ("Expected path not traversed"); + end if; + TC_Credit_Message.Mark_Complete; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or not + This_Transaction.TC_Thru_Distrib then + Report.Failed ("Expected path not traversed"); + end if; + TC_Debit_Message.Mark_Complete; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + task body Distributor is + + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Mark the message as having passed through the distributor + Transaction.TC_Thru_Distrib := true; + + -- Pass this transaction on the appropriate computation + -- task + case Transaction.Code is + when Credit => + requeue Credit_Computation.Input with abort; + when Debit => + requeue Debit_Computation.Input with abort; + end case; + end Input; + or + terminate; + end select; + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Distributor"); + end Distributor; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + -- + task body Credit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input ( Transaction : acc_Transaction_Record) do + -- Perform the computations required for this transaction + null; -- stub + + -- For the test: + if not Transaction.TC_Thru_Distrib then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Credit_Return; + -- one, and only one message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + -- + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + null; -- stub + + -- For the test: + if not Transaction.TC_Thru_Distrib then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + + end Debit_Computation; + + +begin -- c954011 + + Report.Test ("C954011", "Requeue from task body to task entry"); + + Line_Driver.Start; -- Start the test + + -- Ensure that the message tasks complete before reporting the result + while not (TC_Credit_Message.Is_Complete and + TC_Debit_Message.Is_Complete) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + +end C954011; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954012.a b/gcc/testsuite/ada/acats/tests/c9/c954012.a new file mode 100644 index 000000000..44575b1b1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954012.a @@ -0,0 +1,496 @@ +-- C954012.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check a requeue within an accept body to another entry in the same task +-- Specifically, check a call with parameters and a requeue with abort. +-- +-- TEST DESCRIPTION: +-- One transaction is sent through to check the paths. After +-- processing this the Credit task sets the "overloaded" indicator. Once +-- this indicator is set the Distributor queues low priority transactions +-- on a Wait_for_Underload queue in the same task using a requeue. The +-- Distributor still delivers high priority transactions. After two high +-- priority transactions have been processed by the Credit task it clears +-- the overload condition. The low priority transactions should now be +-- delivered. +-- +-- This series of tests uses a simulation of a transaction driven +-- processing system. Line Drivers accept input from an external source +-- and build them into transaction records. These records are then +-- encapsulated in message tasks which remain extant for the life of the +-- transaction in the system. The message tasks put themselves on the +-- input queue of a Distributor which, from information in the +-- transaction and/or system load conditions forwards them to other +-- operating tasks. These in turn might forward the transactions to yet +-- other tasks for further action. The routing is, in real life, dynamic +-- and unpredictable at the time of message generation. All rerouting in +-- this model is done by means of requeues. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 25 Nov 95 SAIC Fixed shared global variable problem for +-- ACVC 2.0.1 +-- 14 Mar 03 RLB Fixed a race condition and an incorrect termination +-- condition in the test. +--! + +with Report; +with ImpDef; +with Ada.Calendar; + +procedure C954012 is + + function "=" (X,Y: Ada.Calendar.Time) return Boolean + renames Ada.Calendar."="; + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + + -- This is used as an "initializing" time for the messages as they are + -- created. As they pass through the Distributor they get a time_stamp + -- of the current time. An arbitrary base time is chosen. + -- TC: this fact is used, incidentally, to check that the messages have, + -- indeed, passed through the Distributor as expected. + -- + Base_Time : Ada.Calendar.Time := Ada.Calendar.Time_of(1959,3,9); + + + -- Mechanism to count the number of Credit Message tasks completed + protected TC_Tasks_Completed is + procedure Increment; + function Count return integer; + private + Number_Complete : integer := 0; + end TC_Tasks_Completed; + + protected type Shared_Boolean (Initial_Value : Boolean := False) is + procedure Set_True; + procedure Set_False; + function Value return Boolean; + private + Current_Value : Boolean := Initial_Value; + end Shared_Boolean; + + protected body Shared_Boolean is + procedure Set_True is + begin + Current_Value := True; + end Set_True; + + procedure Set_False is + begin + Current_Value := False; + end Set_False; + + function Value return Boolean is + begin + return Current_Value; + end Value; + end Shared_Boolean; + + TC_Debit_Message_Complete : Shared_Boolean (False); + -- Handshaking mechanism between the Line Driver and the Credit task + TC_First_Message_Has_Arrived : Shared_Boolean (False); + Credit_Overloaded : Shared_Boolean (False); + + TC_Credit_Messages_Expected : constant integer := 5; + + type Transaction_Code is (Credit, Debit); + type Transaction_Priority is (High, Low); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Priority : Transaction_Priority := High; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + Message_Count : integer := 0; -- for test + Time_Stamp : Ada.Calendar.Time := Base_Time; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + task Distributor is + entry Input (Transaction : acc_Transaction_Record); + entry Wait_for_Underload (Transaction : acc_Transaction_Record); + entry TC_Credit_OK; + end Distributor; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + + -- Mechanism to count the number of Message tasks completed (Credit) + protected body TC_Tasks_Completed is + procedure Increment is + begin + Number_Complete := Number_Complete + 1; + end Increment; + + function Count return integer is + begin + return Number_Complete; + end Count; + end TC_Tasks_Completed; + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- The Line Driver task would normally be designed to loop continuously + -- creating the messages as input is received. Simulate this + -- but limit it to the required number of dummy messages needed for + -- this test and allow it to terminate at that point. Artificially + -- alternate High and Low priority Credit transactions for this test. + -- + task body Line_Driver is + Current_ID : integer := 1; + Current_Priority : Transaction_Priority := High; + + -- Artificial: number of messages required for this test + type TC_Trans_Range is range 1..6; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + Next_Transaction.Priority := Current_Priority; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + accept Start; -- Wait for trigger from Main + + for Transaction_Numb in TC_Trans_Range loop -- TC: limit the loop + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record + := new Transaction_Record; + begin + if Transaction_Numb = TC_Trans_Range'first then + -- Send the first Credit message + Build_Credit_Record ( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + -- TC: Wait until the first message has been received by the + -- Credit task and it has set the Overload indicator for the + -- Distributor + while not TC_First_Message_Has_Arrived.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + elsif Transaction_Numb = TC_Trans_Range'last then + -- For this test send the last transaction to the Debit task + -- to improve the mix + Build_Debit_Record( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + else + -- TC: Alternate high and low priority transactions + if Current_Priority = High then + Current_Priority := Low; + else + Current_Priority := High; + end if; + Build_Credit_Record( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end if; + end; -- declare + end loop; + + -- TC: Wait for Credit_Overloaded to be cleared, then insure that the + -- Distributor has evalated all tasks. Otherwise, some tasks may never + -- be evaluated. + while Credit_Overloaded.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + Distributor.TC_Credit_OK; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + + accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + -- For the test check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= Credit_Return or + This_Transaction.Time_Stamp = Base_Time then + Report.Failed ("Expected path not traversed"); + end if; + TC_Tasks_Completed.Increment; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.Message_Count /= 1 or + This_Transaction.Time_Stamp = Base_Time then + Report.Failed ("Expected path not traversed"); + end if; + TC_Debit_Message_Complete.Set_True; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + + + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + task body Distributor is + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Time_Stamp the messages with the current time + -- TC: Used, incidentally, by the test to check that the + -- message did pass through the Distributor Task + Transaction.Time_Stamp := Ada.Calendar.Clock; + + -- Pass this transaction on to the appropriate computation + -- task but temporarily hold low-priority transactions under + -- overload conditions + case Transaction.Code is + when Credit => + if Credit_Overloaded.Value and + Transaction.Priority = Low then + requeue Wait_for_Underload with abort; + else + requeue Credit_Computation.Input with abort; + end if; + when Debit => + requeue Debit_Computation.Input with abort; + end case; + end Input; + or + when not Credit_Overloaded.Value => + accept Wait_for_Underload (Transaction : acc_Transaction_Record) do + requeue Credit_Computation.Input with abort; + end Wait_for_Underload; + or + accept TC_Credit_OK; + -- We need this to insure that we evaluate the guards at least + -- once when Credit_Overloaded is False. Otherwise, tasks + -- could stay queued on Wait_for_Underload forever (starvation). + or + terminate; + end select; + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Distributor"); + end Distributor; + + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + -- + task body Credit_Computation is + + Message_Count : integer := 0; + + begin + loop + select + accept Input ( Transaction : acc_Transaction_Record) do + if Credit_Overloaded.Value and + Transaction.Priority = Low then + -- We should not be getting any Low Priority messages. They + -- should be waiting on the Distributor's Wait_for_Underload + -- queue + Report.Failed + ("Credit Task: Low priority transaction during overload"); + end if; + -- Perform the computations required for this transaction + null; -- stub + + -- For the test: + if Transaction.Time_Stamp = Base_Time then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- The following is all Test Control code: + Transaction.Return_Value := Credit_Return; + Message_Count := Message_Count + 1; + -- + -- Now take special action depending on which Message + if Message_Count = 1 then + -- After the first message : + Credit_Overloaded.Set_True; + -- Now flag the Line_Driver that the second and subsequent + -- messages may now be sent + TC_First_Message_Has_Arrived.Set_True; + end if; + if Message_Count = 3 then + -- The two high priority transactions created subsequent + -- to the overload have now been processed + Credit_Overloaded.Set_False; + end if; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + -- + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + null; -- stub + + -- For the test: + if Transaction.Time_Stamp = Base_Time then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + + end Debit_Computation; + + +begin -- c954012 + Report.Test ("C954012", "Requeue within an accept body" & + " to another entry in the same task"); + + Line_Driver.Start; -- Start the test + + -- Ensure that the message tasks complete before reporting the result + while (TC_Tasks_Completed.Count < TC_Credit_Messages_Expected) + or (not TC_Debit_Message_Complete.Value) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + +end C954012; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954013.a b/gcc/testsuite/ada/acats/tests/c9/c954013.a new file mode 100644 index 000000000..a9de8c56b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954013.a @@ -0,0 +1,521 @@ +-- C954013.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a requeue is cancelled and that the requeuing task is +-- unaffected when the calling task is aborted. +-- Specifically, check requeue to an entry in a different task, +-- requeue where the entry has parameters, and requeue with abort. +-- +-- TEST DESCRIPTION: +-- Abort a task that has a call requeued to the entry queue of another +-- task. We do this by sending two messages to the Distributor which +-- requeues them to the Credit task. In the accept body of the Credit +-- task we wait for the second message to arrive then check that an +-- abort of the second message task does result in the requeue being +-- removed. The Line Driver task which generates the messages and the +-- Credit task communicate artificially in this test to arrange for the +-- proper timing of the messages and the abort. One extra message is +-- sent to the Debit task to ensure that the Distributor is still viable +-- and has been unaffected by the abort. +-- +-- This series of tests uses a simulation of a transaction driven +-- processing system. Line Drivers accept input from an external source +-- and build them into transaction records. These records are then +-- encapsulated in message tasks which remain extant for the life of the +-- transaction in the system. The message tasks put themselves on the +-- input queue of a Distributor which, from information in the +-- transaction and/or system load conditions forwards them to other +-- operating tasks. These in turn might forward the transactions to yet +-- other tasks for further action. The routing is, in real life, dynamic +-- and unpredictable at the time of message generation. All rerouting in +-- this model is done by means of requeues. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 25 Nov 95 SAIC Fixed shared global variable problems for +-- ACVC 2.0.1 +-- +--! + +with Report; +with ImpDef; + +procedure C954013 is + + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + + protected type Shared_Boolean (Initial_Value : Boolean := False) is + procedure Set_True; + procedure Set_False; + function Value return Boolean; + private + Current_Value : Boolean := Initial_Value; + end Shared_Boolean; + + protected body Shared_Boolean is + procedure Set_True is + begin + Current_Value := True; + end Set_True; + + procedure Set_False is + begin + Current_Value := False; + end Set_False; + + function Value return Boolean is + begin + return Current_Value; + end Value; + end Shared_Boolean; + + + TC_Debit_Message_Complete : Shared_Boolean (False); + TC_Credit_Message_Complete : Shared_Boolean (False); + + + type Transaction_Code is (Credit, Debit); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Dist : Boolean := false; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + task Distributor is + entry Input(Transaction : acc_Transaction_Record); + end Distributor; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + -- This protected object is here for Test Control purposes only + protected TC_Prt is + procedure Set_First_Has_Arrived; + procedure Set_Second_Has_Arrived; + procedure Set_Abort_Has_Completed; + function First_Has_Arrived return Boolean; + function Second_Has_Arrived return Boolean; + function Abort_Has_Completed return Boolean; + private + First_Flag, Second_Flag, Abort_Flag : Boolean := false; + end TC_Prt; + + protected body TC_Prt is + + Procedure Set_First_Has_Arrived is + begin + First_Flag := true; + end Set_First_Has_Arrived; + + Procedure Set_Second_Has_Arrived is + begin + Second_Flag := true; + end Set_Second_Has_Arrived; + + Procedure Set_Abort_Has_Completed is + begin + Abort_Flag := true; + end Set_Abort_Has_Completed; + + Function First_Has_Arrived return boolean is + begin + return First_Flag; + end First_Has_Arrived; + + Function Second_Has_Arrived return boolean is + begin + return Second_Flag; + end Second_has_Arrived; + + Function Abort_Has_Completed return boolean is + begin + return Abort_Flag; + end Abort_Has_Completed; + + end TC_PRT; + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- TC: The Line Driver task would normally be designed to loop + -- continuously creating the messages as input is received. Simulate + -- this but limit it to three dummy messages for this test and use + -- special artificial checks to pace the messages out under controlled + -- conditions for the test; allow it to terminate at the end + -- + task body Line_Driver is + Current_ID : integer := 1; + TC_First_message_sent: Boolean := false; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + accept Start; -- Wait for trigger from main + + for i in 1..3 loop -- TC: arbitrarily limit to two credit messages + -- and one debit, then complete + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record := + new Transaction_Record; + begin + if not TC_First_Message_Sent then + -- send out the first message to start up the Credit task + Build_Credit_Record ( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + TC_First_Message_Sent := true; + elsif not TC_Prt.Abort_Has_Completed then + -- We have not yet processed the second message + -- Wait to send the second message until we know the first + -- has arrived at the Credit task and that task is in the + -- accept body + while not TC_Prt.First_Has_Arrived loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- We can now send the second message + Build_Credit_Record( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + + -- Now wait for the second to arrive on the Credit input queue + while not TC_Prt.Second_Has_Arrived loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- At this point: The Credit task is in the accept block + -- dealing with the first message and the second message is + -- is on the input queue + abort Next_Message_Task.all; -- Note: we are still in the + -- declare block for the + -- second message task + + -- Make absolutely certain that all the actions + -- associated with the abort have been completed, that the + -- task has gone from Abnormal right through to + -- Termination. All requeues that are to going to be + -- cancelled will have been by the point of Termination. + while not Next_Message_Task.all'terminated loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + + -- We now signal the Credit task that the abort has taken place + -- so that it can check that the entry queue is empty as the + -- requeue should have been cancelled + TC_Prt.Set_Abort_Has_Completed; + else + -- The main part of the test is complete. Send one Debit message + -- as further exercise of the Distributor to ensure it has not + -- been affected by the cancellation of the requeue. + Build_Debit_Record ( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end if; + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + + accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + -- For the test check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= Credit_Return or + This_Transaction.TC_Message_Count /= 1 or not + This_Transaction.TC_Thru_Dist then + Report.Failed ("Expected path not traversed"); + end if; + TC_Credit_Message_Complete.Set_True; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or not + This_Transaction.TC_Thru_Dist then + Report.Failed ("Expected path not traversed"); + end if; + TC_Debit_Message_Complete.Set_True; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + task body Distributor is + + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Show that this message did pass through the Distributor Task + Transaction.TC_Thru_Dist := true; + + -- Pass this transaction on the the appropriate computation + -- task + case Transaction.Code is + when Credit => + requeue Credit_Computation.Input with abort; + when Debit => + requeue Debit_Computation.Input with abort; + end case; + end Input; + or + terminate; + end select; + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Distributor"); + end Distributor; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + task body Credit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input ( Transaction : acc_Transaction_Record) do + -- Perform the computations required for this transaction + -- + null; -- stub + + -- The rest of this code is for Test Control + -- + if not Transaction.TC_Thru_Dist then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Credit_Return; + -- one, and only one message should pass through + if Message_Count /= 0 then + Report.Failed ("Aborted Requeue was not cancelled -1"); + end if; + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + + + -- Having done the basic housekeeping we now need to signal + -- that we are in the accept body of the credit task. The + -- first message has arrived and the Line Driver may now send + -- the second one + TC_Prt.Set_First_Has_Arrived; + + -- Now wait for the second to arrive + + while Input'Count = 0 loop + delay ImpDef.Minimum_Task_Switch; + end loop; + -- Second message has been requeued - the Line driver may + -- now abort the calling task + TC_Prt.Set_Second_Has_Arrived; + + -- Now wait for the Line Driver to signal that the abort of + -- the first task is complete - the requeue should be cancelled + -- at this time + while not TC_Prt.Abort_Has_Completed loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + if Input'Count /=0 then + Report.Failed ("Aborted Requeue was not cancelled -2"); + end if; + -- We can now complete the rendezvous with the first caller + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + -- + null; -- stub + + -- The rest of this code is for Test Control + -- + if not Transaction.TC_Thru_Dist then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + + end Debit_Computation; + + +begin -- c954013 + + Report.Test ("C954013", "Abort a task that has a call requeued"); + + Line_Driver.Start; -- start the test + + -- Wait for the message tasks to complete before calling Report.Result. + -- Although two Credit tasks are generated one is aborted so only + -- one completes, thus a single flag is sufficient + -- Note: the test will hang here if there is a problem with the + -- completion of the tasks + while not (TC_Credit_Message_Complete.Value and + TC_Debit_Message_Complete.Value) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + +end C954013; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954014.a b/gcc/testsuite/ada/acats/tests/c9/c954014.a new file mode 100644 index 000000000..53e45a090 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954014.a @@ -0,0 +1,485 @@ +-- C954014.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a requeue is not canceled and that the requeueing +-- task is unaffected when a calling task is aborted. Check that the +-- abort is deferred until the entry call is complete. +-- Specifically, check requeue to an entry in a different task, +-- requeue where the entry call has parameters, and requeue +-- without the abort option. +-- +-- TEST DESCRIPTION +-- In the Driver create a task that places a call on the +-- Distributor. In the Distributor requeue this call on the Credit task. +-- Abort the calling task when it is known to be in rendezvous with the +-- Credit task. (We arrange this by using artificial synchronization +-- points in the Driver and the accept body of the Credit task) Ensure +-- that the abort is deferred (the task is not terminated) until the +-- accept body completes. Afterwards, send one extra message through +-- the Distributor to check that the requeueing task has not been +-- disrupted. +-- +-- This series of tests uses a simulation of a transaction driven +-- processing system. Line Drivers accept input from an external source +-- and build them into transaction records. These records are then +-- encapsulated in message tasks which remain extant for the life of the +-- transaction in the system. The message tasks put themselves on the +-- input queue of a Distributor which, from information in the +-- transaction and/or system load conditions forwards them to other +-- operating tasks. These in turn might forward the transactions to yet +-- other tasks for further action. The routing is, in real life, dynamic +-- and unpredictable at the time of message generation. All rerouting in +-- this model is done by means of requeues. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 25 Nov 95 SAIC Replaced global variables with protected objects +-- for ACVC 2.0.1. +-- +--! + +with Report; +with ImpDef; + +procedure C954014 is + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + + protected type Shared_Boolean (Initial_Value : Boolean := False) is + procedure Set_True; + procedure Set_False; + function Value return Boolean; + private + Current_Value : Boolean := Initial_Value; + end Shared_Boolean; + + protected body Shared_Boolean is + procedure Set_True is + begin + Current_Value := True; + end Set_True; + + procedure Set_False is + begin + Current_Value := False; + end Set_False; + + function Value return Boolean is + begin + return Current_Value; + end Value; + end Shared_Boolean; + + + TC_Debit_Message_Complete : Shared_Boolean (False); + + -- Synchronization flags for handshaking between the Line_Driver + -- and the Accept body in the Credit Task + TC_Handshake_A : Shared_Boolean (False); + TC_Handshake_B : Shared_Boolean (False); + TC_Handshake_C : Shared_Boolean (False); + TC_Handshake_D : Shared_Boolean (False); + TC_Handshake_E : Shared_Boolean (False); + TC_Handshake_F : Shared_Boolean (False); + + + type Transaction_Code is (Credit, Debit); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Distrib : Boolean; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry start; + end Line_Driver; + + task Distributor is + entry Input(Transaction : acc_Transaction_Record); + end Distributor; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- TC: The Line Driver task would normally be designed to loop + -- continuously creating the messages as input is received. Simulate + -- this but limit it to two dummy messages for this test and use + -- special artificial handshaking checks with the Credit accept body + -- to control the test. Allow it to terminate at the end + -- + task body Line_Driver is + Current_ID : integer := 1; + TC_First_message_sent: Boolean := false; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + accept Start; -- Wait for trigger from main + + for i in 1..2 loop -- TC: arbitrarily limit to one credit message + -- and one debit, then complete + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record := + new Transaction_Record; + begin + if not TC_First_Message_Sent then + -- send out the first message which will be aborted + Build_Credit_Record ( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + TC_First_Message_Sent := true; + + -- Wait for Credit task to get into the accept body + -- The call from the Message Task has been requeued by + -- the distributor + while not TC_Handshake_A.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- Abort the calling task; the Credit task is guaranteed to + -- be in the accept body + abort Next_Message_Task.all; -- We are still in this declare + -- block + + -- Inform the Credit task that the abort has been initiated + TC_Handshake_B.Set_True; + + -- Now wait for the "acknowledgment" from the Credit task + -- this ensures a complete task switch (at least) + while not TC_Handshake_C.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- The aborted task must not terminate till the accept body + -- has completed + if Next_Message_Task'terminated then + Report.Failed ("The abort was not deferred"); + end if; + + -- Inform the Credit task that the termination has been checked + TC_Handshake_D.Set_True; + + -- Now wait for the completion of the accept body in the + -- Credit task + while not TC_Handshake_E.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + while not ( Next_Message_Task'terminated ) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- Indicate to the Main program that this section is complete + TC_Handshake_F.Set_True; + + else + -- The main part of the test is complete. Send one Debit message + -- as further exercise of the Distributor to ensure it has not + -- been affected by the abort of the requeue; + Build_Debit_Record ( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end if; + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + + accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + -- For the test check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + -- The only Credit message was the one that should have been aborted + Report.Failed ("Abort was not effective"); + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or not + This_Transaction.TC_Thru_Distrib then + Report.Failed ("Expected path not traversed"); + end if; + TC_Debit_Message_Complete.Set_True; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + task body Distributor is + + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + + -- Indicate that the message did pass through the + -- Distributor Task + Transaction.TC_Thru_Distrib := true; + + -- Pass this transaction on the appropriate computation + -- task + case Transaction.Code is + when Credit => + requeue Credit_Computation.Input; -- without abort + when Debit => + requeue Debit_Computation.Input; -- without abort + end case; + end Input; + or + terminate; + end select; + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Distributor"); + end Distributor; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + task body Credit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input ( Transaction : acc_Transaction_Record) do + -- Perform the computations required for this transaction + -- + null; -- stub + + -- The rest of this code is for Test Control + -- + if not Transaction.TC_Thru_Distrib then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Credit_Return; + -- one, and only one message should pass through + if Message_Count /= 0 then + Report.Failed ("Aborted Requeue was not canceled -1"); + end if; + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + + -- Having done the basic housekeeping we now need to signal + -- that we are in the accept body of the credit task. The + -- message has arrived and the Line Driver may now abort the + -- calling task + TC_Handshake_A.Set_True; + + -- Now wait for the Line Driver to inform us the calling + -- task has been aborted + while not TC_Handshake_B.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- The abort has taken place + -- Inform the Line Driver that we are still running in the + -- accept body + TC_Handshake_C.Set_True; + + -- Now wait for the Line Driver to digest this information + while not TC_Handshake_D.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- The Line driver has checked that the caller is not terminated + -- We can now complete the accept + + end Input; + -- We are out of the accept + TC_Handshake_E.Set_True; + + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + -- + null; -- stub + + -- The rest of this code is for Test Control + -- + if not Transaction.TC_Thru_Distrib then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + + end Debit_Computation; + + +begin -- c954014 + Report.Test ("C954014", "Abort a task that has a call" & + " requeued_without_abort"); + + Line_Driver.Start; -- Start the test + + -- Wait for the message tasks to complete before reporting the result + -- + while not (TC_Handshake_F.Value -- abort not effective? + and TC_Debit_Message_Complete.Value -- Distributor affected? + and TC_Handshake_E.Value ) loop -- accept not completed? + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + +end C954014; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954015.a b/gcc/testsuite/ada/acats/tests/c9/c954015.a new file mode 100644 index 000000000..c86e1078e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954015.a @@ -0,0 +1,549 @@ +-- C954015.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that requeued calls to task entries may, in turn, be requeued. +-- Check that the intermediate requeues are not blocked and that the +-- original caller remains blocked until the last requeue is complete. +-- This test uses: +-- Call with parameters +-- Requeue with abort +-- +-- TEST DESCRIPTION +-- A call is placed on the input queue of the Distributor. The +-- Distributor requeues to the Credit task; the Credit task requeues to a +-- secondary task which, in turn requeues to yet another task. This +-- continues down the chain. At the furthest point of the chain the +-- rendezvous is completed. To verify the action, the furthest task +-- waits in the accept statement for a second message to arrive before +-- completing. This second message can only arrive if none of the earlier +-- tasks in the chain are blocked waiting for completion. Apart from +-- the two Credit messages which are used to check the requeue chain one +-- Debit message is sent to validate the mix. +-- +-- +-- This series of tests uses a simulation of a transaction driven +-- processing system. Line Drivers accept input from an external source +-- and build them into transaction records. These records are then +-- encapsulated in message tasks which remain extant for the life of the +-- transaction in the system. The message tasks put themselves on the +-- input queue of a Distributor which, from information in the +-- transaction and/or system load conditions forwards them to other +-- operating tasks. These in turn might forward the transactions to yet +-- other tasks for further action. The routing is, in real life, dynamic +-- and unpredictable at the time of message generation. All rerouting in +-- this model is done by means of requeues. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +with Report; +with ImpDef; + +procedure C954015 is + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + -- Mechanism to count the number of Credit Message tasks completed + protected TC_Tasks_Completed is + procedure Increment; + function Count return integer; + private + Number_Complete : integer := 0; + end TC_Tasks_Completed; + + TC_Expected_To_Complete : constant integer := 3; + + + -- Values added to the Return_Value indicating passage through the + -- particular task + TC_Credit_Value : constant integer := 1; + TC_Sub_1_Value : constant integer := 2; + TC_Sub_2_Value : constant integer := 3; + TC_Sub_3_Value : constant integer := 4; + TC_Sub_4_Value : constant integer := 5; + -- + TC_Full_Value : integer := TC_Credit_Value + TC_Sub_1_Value + + TC_Sub_2_Value + TC_Sub_3_Value + + TC_Sub_4_Value; + + type Transaction_Code is (Credit, Debit); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Distrib : Boolean := false; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + task Distributor is + entry Input(Transaction : acc_Transaction_Record); + end Distributor; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + -- The following are almost identical for the purpose of the test + task Credit_Sub_1 is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Sub_1; + -- + task Credit_Sub_2 is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Sub_2; + -- + task Credit_Sub_3 is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Sub_3; + + -- This is the last in the chain + task Credit_Sub_4 is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Sub_4; + + + -- Mechanism to count the number of Message tasks completed (Credit) + protected body TC_Tasks_Completed is + procedure Increment is + begin + Number_Complete := Number_Complete + 1; + end Increment; + + function Count return integer is + begin + return Number_Complete; + end Count; + end TC_Tasks_Completed; + + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- The Line Driver task would normally be designed to loop continuously + -- creating the messages as input is received. Simulate this + -- but limit it to the number of dummy messages needed for this + -- test and allow it to terminate at that point. + -- + task body Line_Driver is + Current_ID : integer := 1; + TC_Last_was_for_credit : Boolean := false; + + -- Arbitrary limit for the number of messages sent for this test + type TC_Trans_Range is range 1..3; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + + begin + + accept Start; -- wait for trigger from Main + + -- Arbitrarily limit the loop to the number needed for this test only + for Transaction_Numb in TC_Trans_Range loop + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record := + new Transaction_Record; + begin + -- Artificially send out in the order required + case Transaction_Numb is + when 1 => + Build_Credit_Record( Next_Transaction ); + when 2 => + Build_Credit_Record( Next_Transaction ); + when 3 => + Build_Debit_Record ( Next_Transaction ); + end case; + + -- Present the record to the message task + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + + accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + + -- The following is all Test Control Code + + -- Check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= TC_Full_Value or not + This_Transaction.TC_Thru_Distrib then + Report.Failed ("Expected path not traversed - CR"); + end if; + if + This_Transaction.TC_Message_Count not in 1..2 then + Report.Failed ("Incorrect Message Count"); + end if; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or not + This_Transaction.TC_Thru_Distrib then + Report.Failed ("Expected path not traversed - DB"); + end if; + end if; + TC_Tasks_Completed.Increment; + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + task body Distributor is + + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Show that the message did pass through the Distributor Task + Transaction.TC_Thru_Distrib := true; + + -- Pass this transaction on to the appropriate computation + -- task + case Transaction.Code is + when Credit => + requeue Credit_Computation.Input with abort; + when Debit => + requeue Debit_Computation.Input with abort; + end case; + end Input; + or + terminate; + end select; + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Distributor"); + end Distributor; + + + + + -- Computation task. + -- Note: After the computation is performed in this task the message is + -- passed on for further processing to some subsidiary task. The choice + -- of subsidiary task is made according to criteria not specified in + -- this test. + -- + task body Credit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input ( Transaction : acc_Transaction_Record) do + -- Perform the computations required for this transaction + null; -- stub + + -- For the test: + if not Transaction.TC_Thru_Distrib then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test, plug a known value and count + Transaction.Return_Value := TC_Credit_Value; + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + + -- Depending on transaction content send it on to the + -- some other task for further processing + -- TC: Arbitrarily send the message on to Credit_Sub_1 + requeue Credit_Sub_1.Input with abort; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + task body Credit_Sub_1 is + begin + loop + select + accept Input(Transaction : acc_Transaction_Record) do + -- Process this transaction + null; -- stub + + -- Add the value showing passage through this task + Transaction.Return_Value := + Transaction.Return_Value + TC_Sub_1_Value; + -- Depending on transaction content send it on to the + -- some other task for further processing + -- Arbitrarily send the message on to Credit_Sub_2 + requeue Credit_Sub_2.Input with abort; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Sub_1"); + + end Credit_Sub_1; + + task body Credit_Sub_2 is + begin + loop + select + accept Input(Transaction : acc_Transaction_Record) do + -- Process this transaction + null; -- stub + + -- Add the value showing passage through this task + Transaction.Return_Value := + Transaction.Return_Value + TC_Sub_2_Value; + -- Depending on transaction content send it on to the + -- some other task for further processing + -- Arbitrarily send the message on to Credit_Sub_3 + requeue Credit_Sub_3.Input with abort; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Sub_2"); + end Credit_Sub_2; + + task body Credit_Sub_3 is + begin + loop + select + accept Input(Transaction : acc_Transaction_Record) do + -- Process this transaction + null; -- stub + + -- Add the value showing passage through this task + Transaction.Return_Value := + Transaction.Return_Value + TC_Sub_3_Value; + -- Depending on transaction content send it on to the + -- some other task for further processing + -- Arbitrarily send the message on to Credit_Sub_4 + requeue Credit_Sub_4.Input with abort; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Sub_3"); + end Credit_Sub_3; + + -- This is the last in the chain of tasks to which transactions will + -- be requeued + -- + task body Credit_Sub_4 is + + TC_First_Message : Boolean := true; + + begin + loop + select + accept Input(Transaction : acc_Transaction_Record) do + -- Process this transaction + null; -- stub + + -- Add the value showing passage through this task + Transaction.Return_Value := + Transaction.Return_Value + TC_Sub_4_Value; + -- TC: stay in the accept body dealing with the first message + -- until the second arrives. If any of the requeues are + -- blocked the test will hang here indicating failure + if TC_First_Message then + while Input'count = 0 loop + delay ImpDef.Minimum_Task_Switch; + end loop; + TC_First_Message := false; + end if; + -- for the second message, just complete the rendezvous + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Sub_4"); + end Credit_Sub_4; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + -- + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + null; -- stub + + -- For the test: + if not Transaction.TC_Thru_Distrib then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + + end Debit_Computation; + + +begin + + Report.Test ("C954015", "Test multiple levels of requeue to task entry"); + + Line_Driver.Start; -- Start the test + + -- Ensure that the message tasks completed before calling Result + while (TC_Tasks_Completed.Count < TC_Expected_To_Complete) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + +end C954015; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954016.a b/gcc/testsuite/ada/acats/tests/c9/c954016.a new file mode 100644 index 000000000..1390801ee --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954016.a @@ -0,0 +1,182 @@ +-- C954016.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that when a task that is called by a requeue is aborted, the +-- original caller receives Tasking_Error and the requeuing task is +-- unaffected. +-- +-- TEST DESCRIPTION: +-- The Intermediate task requeues a call from the Original_Caller to the +-- Receiver. While the Receiver is in the accept body for this +-- rendezvous the Main aborts it. Check that Tasking_Error is raised in +-- the Original_Caller, that the Receiver does, indeed, get aborted and +-- the Intermediate task is undisturbed. +-- There are several delay loops in this test any one of which could +-- cause it to hang which would constitute failure. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 25 Nov 95 SAIC Replaced shared global variable with protected +-- object for ACVC 2.0.1 +-- +--! + +with Report; +with ImpDef; + +procedure C954016 is + + TC_Original_Caller_Complete : Boolean := false; + TC_Intermediate_Complete : Boolean := false; + + + protected type Shared_Boolean (Initial_Value : Boolean := False) is + procedure Set_True; + procedure Set_False; + function Value return Boolean; + private + Current_Value : Boolean := Initial_Value; + end Shared_Boolean; + + protected body Shared_Boolean is + procedure Set_True is + begin + Current_Value := True; + end Set_True; + + procedure Set_False is + begin + Current_Value := False; + end Set_False; + + function Value return Boolean is + begin + return Current_Value; + end Value; + end Shared_Boolean; + + TC_Receiver_in_Accept : Shared_Boolean (False); + + + task Original_Caller is + entry Start; + end Original_Caller; + + task Intermediate is + entry Input; + entry TC_Abort_Process_Complete; + end Intermediate; + + task Receiver is + entry Input; + entry TC_Never_Called; + end Receiver; + + + task body Original_Caller is + begin + accept Start; -- wait for the trigger from Main + + Intermediate.Input; + Report.Failed ("Tasking_Error not raised in Original_Caller task"); + + exception + when tasking_error => + TC_Original_Caller_Complete := true; -- expected behavior + when others => + Report.Failed ("Unexpected Exception in Original_Caller task"); + end Original_Caller; + + + task body Intermediate is + begin + accept Input do + -- Within this accept call another task + requeue Receiver.Input with abort; + end Input; + + -- Wait for Main to ensure that the abort housekeeping is finished + accept TC_Abort_Process_Complete; + + TC_Intermediate_Complete := true; + + exception + when others => + Report.Failed ("Unexpected exception in Intermediate task"); + end Intermediate; + + + task body Receiver is + begin + accept Input do + TC_Receiver_in_Accept.Set_True; + -- Hang within the accept body to allow Main to abort this task + accept TC_Never_Called; + end Input; + exception + when others => + Report.Failed ("Unexpected Exception in Receiver Task"); + + end Receiver; + + +begin + Report.Test ("C954016", "Requeue: abort the called task"); + + Original_Caller.Start; + + -- Wait till the rendezvous with Receiver is started + while not TC_Receiver_in_Accept.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- At this point the Receiver is guaranteed to be in its accept + -- + abort Receiver; + + -- Wait for the whole of the abort process to complete + while not ( Original_Caller'terminated and Receiver'terminated ) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- Inform the Intermediate task that the process is complete to allow + -- it to continue to completion itself + Intermediate.TC_Abort_Process_Complete; + + -- Wait for everything to settle before reporting the result + while not ( Intermediate'terminated ) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + + if not ( TC_Original_Caller_Complete and TC_Intermediate_Complete ) then + Report.Failed ("Proper paths not traversed"); + end if; + + Report.Result; + +end C954016; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954017.a b/gcc/testsuite/ada/acats/tests/c9/c954017.a new file mode 100644 index 000000000..a5447a756 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954017.a @@ -0,0 +1,184 @@ +-- C954017.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that when an exception is raised in the rendezvous of a task +-- that was called by a requeue the exception is propagated to the +-- original caller and that the requeuing task is unaffected. +-- +-- TEST DESCRIPTION: +-- The Intermediate task requeues a call from the Original_Caller to the +-- Receiver. While the Receiver is in the accept body for this +-- rendezvous a Constraint_Error exception is raised. Check that the +-- exception is propagated to the Original_Caller, that the Receiver's +-- normal exception logic is employed and that the Intermediate task +-- is undisturbed. +-- There are several delay loops in this test any one of which could +-- cause it to hang (and thus fail). +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 25 Nov 95 SAIC Fixed shared global variable problem for +-- ACVC 2.0.1 +-- +--! + +with Report; +with ImpDef; + + +procedure C954017 is + + TC_Original_Caller_Complete : Boolean := false; + TC_Intermediate_Complete : Boolean := false; + TC_Receiver_Complete : Boolean := false; + TC_Exception : Exception; + + + protected type Shared_Boolean (Initial_Value : Boolean := False) is + procedure Set_True; + procedure Set_False; + function Value return Boolean; + private + Current_Value : Boolean := Initial_Value; + end Shared_Boolean; + + protected body Shared_Boolean is + procedure Set_True is + begin + Current_Value := True; + end Set_True; + + procedure Set_False is + begin + Current_Value := False; + end Set_False; + + function Value return Boolean is + begin + return Current_Value; + end Value; + end Shared_Boolean; + + TC_Exception_Process_Complete : Shared_Boolean (False); + + task Original_Caller is + entry Start; + end Original_Caller; + + task Intermediate is + entry Input; + end Intermediate; + + task Receiver is + entry Input; + end Receiver; + + + task body Original_Caller is + begin + accept Start; -- wait for the trigger from Main + + Intermediate.Input; + Report.Failed ("Exception not propagated to Original_Caller"); + + exception + when TC_Exception => + TC_Original_Caller_Complete := true; -- Expected behavior + when others => + Report.Failed ("Unexpected Exception in Original_Caller task"); + end Original_Caller; + + + task body Intermediate is + begin + accept Input do + -- Within this accept call another task + requeue Receiver.Input with abort; + end Input; + + -- Wait for Main to ensure that the exception housekeeping is finished + while not TC_Exception_Process_Complete.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + TC_Intermediate_Complete := true; + + exception + when others => + Report.Failed ("Unexpected exception in Intermediate task"); + end Intermediate; + + + task body Receiver is + -- + begin + accept Input do + null; -- the user code for the rendezvous is stubbed out + + -- Test Control: Raise an exception in the destination task which + -- should then be propagated + raise TC_Exception; + + end Input; + exception + when TC_Exception => + TC_Receiver_Complete := true; -- expected behavior + when others => + Report.Failed ("Unexpected Exception in Receiver Task"); + end Receiver; + + +begin + + Report.Test ("C954017", "Requeue: exception processing"); + + Original_Caller.Start; -- Start the test after the Report.Test + + -- Wait for the whole of the exception process to complete + while not ( Original_Caller'terminated and Receiver'terminated ) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- Inform the Intermediate task that the process is complete to allow + -- it to continue to completion itself + TC_Exception_Process_Complete.Set_True; + + -- Wait for everything to settle before reporting the result + while not ( Intermediate'terminated ) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + + if not ( TC_Original_Caller_Complete and + TC_Intermediate_Complete and + TC_Receiver_Complete) then + Report.Failed ("Proper paths not traversed"); + end if; + + Report.Result; + +end C954017; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954018.a b/gcc/testsuite/ada/acats/tests/c9/c954018.a new file mode 100644 index 000000000..a9da1e06b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954018.a @@ -0,0 +1,227 @@ +-- C954018.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that if a task is aborted while a requeued call is queued +-- on one of its entries the original caller receives Tasking_Error +-- and the requeuing task is unaffected. +-- This test uses: Requeue to an entry in a different task +-- Parameterless call +-- Requeue with abort +-- +-- TEST DESCRIPTION: +-- The Intermediate task requeues a call from the Original_Caller to the +-- Receiver on an entry with a guard that is always false. While the +-- Original_Caller is still queued the Receiver is aborted. +-- Check that Tasking_Error is raised in the Original_Caller, that the +-- Receiver does, indeed, get aborted and the Intermediate task +-- is undisturbed. +-- There are several delay loops in this test any one of which could +-- cause it to hang and thus indicate failure. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +with Report; +with ImpDef; + + +procedure C954018 is + + + -- Protected object to control the shared test variables + -- + protected TC_State is + function On_Entry_Queue return Boolean; + procedure Set_On_Entry_Queue; + function Original_Caller_Complete return Boolean; + procedure Set_Original_Caller_Complete; + function Intermediate_Complete return Boolean; + procedure Set_Intermediate_Complete; + private + On_Entry_Queue_Flag : Boolean := false; + Original_Caller_Complete_Flag : Boolean := false; + Intermediate_Complete_Flag : Boolean := false; + end TC_State; + -- + -- + protected body TC_State is + function On_Entry_Queue return Boolean is + begin + return On_Entry_Queue_Flag; + end On_Entry_Queue; + + procedure Set_On_Entry_Queue is + begin + On_Entry_Queue_Flag := true; + end Set_On_Entry_Queue; + + function Original_Caller_Complete return Boolean is + begin + return Original_Caller_Complete_Flag; + end Original_Caller_Complete; + + procedure Set_Original_Caller_Complete is + begin + Original_Caller_Complete_Flag := true; + end Set_Original_Caller_Complete; + + function Intermediate_Complete return Boolean is + begin + return Intermediate_Complete_Flag; + end Intermediate_Complete; + + procedure Set_Intermediate_Complete is + begin + Intermediate_Complete_Flag := true; + end Set_Intermediate_Complete; + + end TC_State; + + --================================ + + task Original_Caller is + entry Start; + end Original_Caller; + + task Intermediate is + entry Input; + entry TC_Abort_Process_Complete; + end Intermediate; + + task Receiver is + entry Input; + end Receiver; + + + task body Original_Caller is + begin + accept Start; -- wait for the trigger from Main + + Intermediate.Input; + Report.Failed ("Tasking_Error not raised in Original_Caller task"); + + exception + when tasking_error => + TC_State.Set_Original_Caller_Complete; -- expected behavior + when others => + Report.Failed ("Unexpected Exception in Original_Caller task"); + end Original_Caller; + + + task body Intermediate is + begin + accept Input do + -- Within this accept call another task + TC_State.Set_On_Entry_Queue; + requeue Receiver.Input with abort; + Report.Failed ("Requeue did not complete the Accept"); + end Input; + + -- Wait for Main to ensure that the abort housekeeping is finished + accept TC_Abort_Process_Complete; + + TC_State.Set_Intermediate_Complete; + + exception + when others => + Report.Failed ("Unexpected exception in Intermediate task"); + end Intermediate; + + + task body Receiver is + begin + loop + select + -- A call to Input will be placed on the queue and never serviced + when Report.Equal (1,2) => -- Always false + accept Input do + Report.Failed ("Receiver in Accept"); + end Input; + or + delay ImpDef.Minimum_Task_Switch; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected Exception in Receiver Task"); + + end Receiver; + + +begin + + Report.Test ("C954018", "Requeue: abort the called task" & + " while Caller is still queued"); + + Original_Caller.Start; + + + -- This is the main part of the test + + -- Wait for the requeue + while not TC_State.On_Entry_Queue loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- Delay long enough to ensure that the requeue has "arrived" on + -- the entry queue. Note: TC_State.Set_On_Entry_Queue is called the + -- statement before the requeue + -- + delay ImpDef.Switch_To_New_Task; + + -- At this point the Receiver is guaranteed to have the requeue on + -- the entry queue + -- + abort Receiver; + + -- Wait for the whole of the abort process to complete + while not ( Original_Caller'terminated and Receiver'terminated ) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + + -- Inform the Intermediate task that the process is complete to allow + -- it to continue to completion itself + Intermediate.TC_Abort_Process_Complete; + + -- Wait for everything to settle before reporting the result + while not ( Intermediate'terminated ) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + + if not ( TC_State.Original_Caller_Complete and + TC_State.Intermediate_Complete ) then + Report.Failed ("Proper paths not traversed"); + end if; + + Report.Result; + +end C954018; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954019.a b/gcc/testsuite/ada/acats/tests/c9/c954019.a new file mode 100644 index 000000000..fafc6aa59 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954019.a @@ -0,0 +1,314 @@ +-- C954019.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that when a requeue is to the same entry the items go to the +-- right queue and that they are placed back on the end of the queue. +-- +-- TEST DESCRIPTION: +-- Simulate part of a message handling application where the messages are +-- composed of several segments. The sequence of the segments within the +-- message is specified by Seg_Sequence_No. The segments are handled by +-- different tasks and finally forwarded to an output driver. The +-- segments can arrive in any order but must be assembled into the proper +-- sequence for final output. There is a Sequencer task interposed +-- before the Driver. This takes the segments of the message off the +-- Ordering_Queue and those that are in the right order it sends on to +-- the driver; those that are out of order it places back on the end of +-- the queue. +-- +-- The test just simulates the arrival of the segments at the Sequencer. +-- The task generating the segments handshakes with the Sequencer during +-- the "Await Arrival" phase ensuring that the three segments of a +-- message arrive in REVERSE order (the End-of-Message segment arrives +-- first and the Header last). In the first cycle the sequencer pulls +-- segments off the queue and puts them back on the end till it +-- encounters the header. It checks the sequence of the ones it pulls +-- off in case the segments are being put back on in the wrong part of +-- the queue. Having cycled once through it no longer verifies the +-- sequence - it just executes the "application" code for the correct +-- order for dispatch to the driver. +-- +-- In this simple example no attempt is made to address segments of +-- another message arriving or any other error conditions (such as +-- missing segments, timing etc.) +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 19 Dec 94 SAIC Remove parameter from requeue statement +-- +--! + +with Report; +with ImpDef; + +procedure C954019 is +begin + + + Report.Test ("C954019", "Check Requeue to the same Accept"); + + declare -- encapsulate the test + + type Segment_Sequence is range 1..8; + Header : constant Segment_Sequence := Segment_Sequence'first; + + type Message_Segment is record + ID : integer; -- Message ID + Seg_Sequence_No : Segment_Sequence; -- Within the message + Alpha : string (1..128); + EOM : Boolean := false; -- true for final msg segment + end record; + type acc_Message_Segment is access Message_Segment; + + task TC_Simulate_Arrival; + + task type Carrier_Task is + entry Input ( Segment : acc_Message_Segment ); + end Carrier_Task; + type acc_Carrier_Task is access Carrier_Task; + + task Sequencer is + entry Ordering_Queue ( Segment : acc_Message_Segment ); + entry TC_Handshake_1; + entry TC_Handshake_2; + end Sequencer; + + task Output_Driver is + entry Input ( Segment : acc_Message_Segment ); + end Output_Driver; + + + -- Simulate the arrival of three message segments in REVERSE order + -- + task body TC_Simulate_Arrival is + begin + + for i in 1..3 loop + declare + -- Create a task for the next message segment + Next_Segment_Task : acc_Carrier_Task := new Carrier_Task; + -- Create a record for the next segment + Next_Segment : acc_Message_Segment := new Message_Segment; + begin + if i = 1 then + -- Build the EOM segment as the first to "send" + Next_Segment.Seg_Sequence_No := Header + 2; + Next_Segment.EOM := true; + elsif i = 2 then + -- Wait for the first segment to arrive at the Sequencer + -- before "sending" the second + Sequencer.TC_Handshake_1; + -- Build the segment + Next_Segment.Seg_Sequence_No := Header + 1; + else + -- Wait for the second segment to arrive at the Sequencer + -- before "sending" the third + Sequencer.TC_Handshake_2; + -- Build the segment. The last segment in order to + -- arrive will be the "header" segment + Next_Segment.Seg_Sequence_No := Header; + end if; + -- pass the record to its carrier + Next_Segment_Task.Input ( Next_Segment ); + end; + end loop; + exception + when others => + Report.Failed ("Unexpected Exception in TC_Simulate_Arrival"); + end TC_Simulate_Arrival; + + + -- One of these is generated for each message segment and the flow + -- of the segments through the system is controlled by the calls the + -- task makes and the requeues of those calls + -- + task body Carrier_Task is + This_Segment : acc_Message_Segment := new Message_Segment; + begin + accept Input ( Segment : acc_Message_Segment ) do + This_Segment.all := Segment.all; + end Input; + null; --:: stub. Pass the segment around the application as needed + + -- Now output the segment to the Output_Driver. First we have to + -- go through the Sequencer. + Sequencer.Ordering_Queue ( This_Segment ); + exception + when others => + Report.Failed ("Unexpected Exception in Carrier_Task"); + end Carrier_Task; + + + -- Pull segments off the Ordering_Queue and deliver them in the correct + -- sequence to the Output_Driver. + -- + task body Sequencer is + Next_Needed : Segment_Sequence := Header; + + TC_Await_Arrival : Boolean := true; + TC_First_Cycle : Boolean := true; + TC_Expected_Sequence : Segment_Sequence := Header+2; + begin + loop + select + accept Ordering_Queue ( Segment : acc_Message_Segment ) do + + --===================================================== + -- This part is all Test_Control code + + if TC_Await_Arrival then + -- We have to arrange that the segments arrive on the + -- queue in the right order, so we handshake with the + -- TC_Simulate_Arrival task to "send" only one at + -- a time + accept TC_Handshake_1; -- the first has arrived + -- and has been pulled off the + -- queue + + -- Wait for the second to arrive (the first has already + -- been pulled off the queue + while Ordering_Queue'count < 1 loop + delay ImpDef.Minimum_Task_Switch; + end loop; + -- + accept TC_Handshake_2; -- the second has arrived + + -- Wait for the third to arrive + while Ordering_Queue'count < 2 loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- Subsequent passes through the loop, bypass this code + TC_Await_Arrival := false; + + + end if; -- await arrival + + if TC_First_Cycle then + -- Check the order of the original three + if Segment.Seg_Sequence_No /= TC_Expected_Sequence then + -- The segments are not being pulled off in the + -- expected sequence. This could occur if the + -- requeue is not putting them back on the end. + Report.Failed ("Sequencer: Segment out of sequence"); + end if; -- sequence check + -- Decrement the expected sequence + if TC_Expected_Sequence /= Header then + TC_Expected_Sequence := TC_Expected_Sequence - 1; + else + TC_First_Cycle := false; -- This is the Header - the + -- first two segments are + -- back on the queue + + end if; -- decrementing + end if; -- first pass + --===================================================== + + -- And this is the Application code + if Segment.Seg_Sequence_No = Next_Needed then + if Segment.EOM then + Next_Needed := Header; -- reset for next message + else + Next_Needed := Next_Needed + 1; + end if; + requeue Output_Driver.Input with abort; + Report.Failed ("Requeue did not complete accept body"); + else + -- Not the next needed - put it back on the queue + requeue Sequencer.Ordering_Queue; + Report.Failed ("Requeue did not complete accept body"); + end if; + end Ordering_Queue; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected Exception in Sequencer"); + end Sequencer; + + + task body Output_Driver is + This_Segment : acc_Message_Segment := new Message_Segment; + + TC_Expected_Sequence : Segment_Sequence := Segment_Sequence'first; + TC_Segment_Total : integer := 0; + TC_Expected_Total : integer := 3; + begin + loop + -- Note: normally we would expect this Accept to be in a select + -- with terminate. For the test we exit the loop on completion + -- to give better control + accept Input ( Segment : acc_Message_Segment ) do + This_Segment.all := Segment.all; + end Input; + + null; --::: stub - output the next segment of the message + + -- The following is all test control code + -- + if This_Segment.Seg_Sequence_No /= TC_Expected_Sequence then + Report.Failed ("Output_Driver: Segment out of sequence"); + end if; + TC_Expected_Sequence := TC_Expected_Sequence + 1; + + -- Now count the number of segments + TC_Segment_Total := TC_Segment_Total + 1; + + -- Check the number and exit loop when complete + -- There must be exactly TC_Expected_Total in number and + -- the last one must be EOM + -- (test will hang if < TC_Expected_Total arrive + -- without EOM) + if This_Segment.EOM then + -- This is the last segment. + if TC_Segment_Total /= TC_Expected_Total then + Report.Failed ("EOM and wrong number of segments"); + end if; + exit; -- the loop and terminate the task + elsif TC_Segment_Total = TC_Expected_Total then + Report.Failed ("No EOM found"); + exit; + end if; + end loop; + exception + when others => + Report.Failed ("Unexpected Exception in Output_Driver"); + end Output_Driver; + + + + begin + + null; + + end; -- encapsulation + + Report.Result; + +end C954019; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954020.a b/gcc/testsuite/ada/acats/tests/c9/c954020.a new file mode 100644 index 000000000..bc08a6bd4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954020.a @@ -0,0 +1,422 @@ +-- C954020.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a call to a protected entry can be requeued to a task +-- entry. Check that the requeue is placed on the correct entry; that the +-- original caller waits for the completion of the requeue and continues +-- after the requeued rendezvous. Check that the requeue does not block. +-- Specifically, check a requeue with abort from a protected entry to +-- an entry in a task. +-- +-- TEST DESCRIPTION: +-- +-- In the Distributor protected object, requeue two successive calls on +-- the entries of two separate target tasks. Each task in each of the +-- paths adds identifying information in the transaction being passed. +-- This information is checked by the Message tasks on completion +-- ensuring that the requeues have been placed on the correct queues. +-- There is an artificial guard on the Credit Task to ensure that the +-- input is queued; this guard is released by the Debit task which +-- handles its input immediately. This ensures that we have one of the +-- requeued items actually queued for later handling and also verifies +-- that the requeuing process (in the protected object) is not blocked. +-- +-- This series of tests uses a simulation of a transaction driven +-- processing system. Line Drivers accept input from an external source +-- and build them into transaction records. These records are then +-- encapsulated in message tasks which remain extant for the life of the +-- transaction in the system. The message tasks put themselves on the +-- input queue of a Distributor object which, from information in the +-- transaction and/or system load conditions forwards them to other +-- operating tasks. These in turn might forward the transactions to yet +-- other tasks for further action. The routing is, in real life, +-- dynamic and unpredictable at the time of message generation. All +-- rerouting in this model is done by means of requeues. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 06 Nov 95 SAIC Fixed problems for ACVC 2.0.1 +-- +--! + +with Report; +with ImpDef; + +procedure C954020 is + Verbose : constant Boolean := False; + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + protected type Message_Status is + procedure Set_Complete; + function Complete return Boolean; + private + Is_Complete : Boolean := False; + end Message_Status; + + protected body Message_Status is + procedure Set_Complete is + begin + Is_Complete := True; + end Set_Complete; + + function Complete return Boolean is + begin + return Is_Complete; + end Complete; + end Message_Status; + + TC_Debit_Message : Message_Status; + TC_Credit_Message : Message_Status; + + type Transaction_Code is (Credit, Debit); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Dist : Boolean := false; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + protected Time_Lock is + procedure Credit_Start; + function Credit_Enabled return Boolean; + private + Credit_OK : Boolean := false; + end Time_Lock; + + protected body Time_Lock is + procedure Credit_Start is + begin + Credit_OK := true; + end Credit_Start; + + function Credit_Enabled return Boolean is + begin + return Credit_OK; + end Credit_Enabled; + end Time_Lock; + + + + protected Distributor is + entry Input (Transaction : acc_Transaction_Record); + end Distributor; + -- + -- + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + protected body Distributor is + entry Input (Transaction : acc_Transaction_Record) when true is + -- barrier is always open + begin + -- Test Control: Set the indicator in the message to show it has + -- passed through the Distributor object + Transaction.TC_thru_Dist := true; + + -- Pass this transaction on to the appropriate computation + -- task + case Transaction.Code is + when Credit => + requeue Credit_Computation.Input with abort; + when Debit => + requeue Debit_Computation.Input with abort; + end case; + end Input; + end Distributor; + + + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- The Line Driver task would normally be designed to loop continuously + -- creating the messages as input is received. Simulate this + -- but limit it to two dummy messages for this test and allow it + -- to terminate at that point + -- + task body Line_Driver is + Current_ID : integer := 1; + TC_Last_was_for_credit : Boolean := false; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + accept Start; -- Wait for trigger from Main + + for i in 1..2 loop -- arbitrarily limit to two messages for the test + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record + := new Transaction_Record; + begin + if TC_Last_was_for_credit then + Build_Debit_Record ( Next_Transaction ); + else + Build_Credit_Record( Next_Transaction ); + TC_Last_was_for_credit := true; + end if; + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + if Verbose then + Report.Comment ("message task got " & + Transaction_Code'Image (This_Transaction.Code)); + end if; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + + -- The following is all Test Control Code + + -- Check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= Credit_Return or + This_Transaction.TC_Message_Count /= 1 or + not This_Transaction.TC_thru_Dist then + Report.Failed ("Expected path not traversed"); + end if; + TC_Credit_Message.Set_Complete; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or + not This_Transaction.TC_thru_Dist then + Report.Failed ("Expected path not traversed"); + end if; + TC_Debit_Message.Set_Complete; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + -- + task body Credit_Computation is + Message_Count : integer := 0; + begin + loop + select + when Time_Lock.Credit_enabled => + accept Input ( Transaction : acc_Transaction_Record) do + -- Perform the computations required for this transaction + null; -- stub + + if Verbose then + Report.Comment ("Credit_Computation in accept"); + end if; + + -- For the test: + if not Transaction.TC_thru_Dist then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Credit_Return; + -- one, and only one message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + + end Input; + exit; -- only handle 1 transaction + else + -- poll until we can accept credit transaction + delay ImpDef.Clear_Ready_Queue; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + -- + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + null; -- stub + + if Verbose then + Report.Comment ("Debit_Computation in accept"); + end if; + + -- For the test: + if not Transaction.TC_thru_Dist then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + -- for the test: once we have completed the only Debit + -- message release the Credit Messages which are queued + -- on the Credit Input queue + Time_Lock.Credit_Start; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + + end Debit_Computation; + + +begin -- C954020 + + Report.Test ("C954020", "Requeue, with abort, from protected entry " & + "to task entry"); + + Line_Driver.Start; -- Start the test + + -- Ensure that the message tasks complete before reporting the result + while not (TC_Credit_Message.Complete and TC_Debit_Message.Complete) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + +end C954020; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954021.a b/gcc/testsuite/ada/acats/tests/c9/c954021.a new file mode 100644 index 000000000..626f2f970 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954021.a @@ -0,0 +1,524 @@ +-- C954021.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a requeue within a protected entry to an entry in a +-- different protected object is queued correctly. +-- +-- TEST DESCRIPTION: +-- One transaction is sent through to check the paths. After processing +-- this the Credit task sets the "overloaded" indicator. Once this +-- indicator is set the Distributor (a protected object) queues low +-- priority transactions on a Wait_for_Underload queue in another +-- protected object using a requeue. The Distributor still delivers high +-- priority transactions. After two high priority transactions have been +-- processed by the Credit task it clears the overload condition. The +-- low priority transactions should now be delivered. +-- +-- This series of tests uses a simulation of a transaction driven +-- processing system. Line Drivers accept input from an external source +-- and build them into transaction records. These records are then +-- encapsulated in message tasks which remain extant for the life of the +-- transaction in the system. The message tasks put themselves on the +-- input queue of a Distributor which, from information in the +-- transaction and/or system load conditions forwards them to other +-- operating tasks. These in turn might forward the transactions to yet +-- other tasks for further action. The routing is, in real life, dynamic +-- and unpredictable at the time of message generation. All rerouting in +-- this model is done by means of requeues. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 26 Nov 95 SAIC Fixed shared global variable for ACVC 2.0.1 +-- +--! + +with Report; +with ImpDef; + +procedure C954021 is + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + + -- Mechanism to count the number of Credit Message tasks completed + protected TC_Tasks_Completed is + procedure Increment; + function Count return integer; + private + Number_Complete : integer := 0; + end TC_Tasks_Completed; + + + TC_Credit_Messages_Expected : constant integer := 5; + + protected TC_Handshake is + procedure Set; + function First_Message_Arrived return Boolean; + private + Arrived_Flag : Boolean := false; + end TC_Handshake; + + -- Handshaking mechanism between the Line Driver and the Credit task + -- + protected body TC_Handshake is + -- + procedure Set is + begin + Arrived_Flag := true; + end Set; + -- + function First_Message_Arrived return Boolean is + begin + return Arrived_Flag; + end First_Message_Arrived; + -- + end TC_Handshake; + + + protected type Shared_Boolean (Initial_Value : Boolean := False) is + procedure Set_True; + procedure Set_False; + function Value return Boolean; + private + Current_Value : Boolean := Initial_Value; + end Shared_Boolean; + + protected body Shared_Boolean is + procedure Set_True is + begin + Current_Value := True; + end Set_True; + + procedure Set_False is + begin + Current_Value := False; + end Set_False; + + function Value return Boolean is + begin + return Current_Value; + end Value; + end Shared_Boolean; + + TC_Debit_Message_Complete : Shared_Boolean (False); + + type Transaction_Code is (Credit, Debit); + type Transaction_Priority is (High, Low); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Priority : Transaction_Priority := High; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Dist : Boolean := false; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + protected Distributor is + procedure Set_Credit_Overloaded; + procedure Clear_Credit_Overloaded; + function Credit_is_Overloaded return Boolean; + entry Input (Transaction : acc_Transaction_Record); + private + Credit_Overloaded : Boolean := false; + end Distributor; + + protected Hold is + procedure Underloaded; + entry Wait_for_Underload (Transaction : acc_Transaction_Record); + private + Release_All : Boolean := false; + end Hold; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + -- + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + protected body Distributor is + + procedure Set_Credit_Overloaded is + begin + Credit_Overloaded := true; + end Set_Credit_Overloaded; + + procedure Clear_Credit_Overloaded is + begin + Credit_Overloaded := false; + Hold.Underloaded; -- Release all held messages + end Clear_Credit_Overloaded; + + function Credit_is_Overloaded return Boolean is + begin + return Credit_Overloaded; + end Credit_is_Overloaded; + + + entry Input (Transaction : acc_Transaction_Record) when true is + -- barrier is always open + begin + -- Test Control: Set the indicator in the message to show it has + -- passed through the Distributor object + Transaction.TC_thru_Dist := true; + + -- Pass this transaction on to the appropriate computation + -- task but temporarily hold low-priority transactions under + -- overload conditions + case Transaction.Code is + when Credit => + if Credit_Overloaded and Transaction.Priority = Low then + requeue Hold.Wait_for_Underload with abort; + else + requeue Credit_Computation.Input with abort; + end if; + when Debit => + requeue Debit_Computation.Input with abort; + end case; + end Input; + end Distributor; + + + -- Low priority Message tasks are held on the Wait_for_Underload queue + -- while the Credit computation system is overloaded. Once the Credit + -- system reached underload send all queued messages immediately + -- + protected body Hold is + + -- Once this is executed the barrier condition for the entry is + -- evaluated + procedure Underloaded is + begin + Release_All := true; + end Underloaded; + + entry Wait_for_Underload (Transaction : acc_Transaction_Record) + when Release_All is + begin + requeue Credit_Computation.Input with abort; + if Wait_for_Underload'count = 0 then + -- Queue is purged. Set up to hold next batch + Release_All := false; + end if; + end Wait_for_Underload; + + end Hold; + + -- Mechanism to count the number of Message tasks completed (Credit) + protected body TC_Tasks_Completed is + procedure Increment is + begin + Number_Complete := Number_Complete + 1; + end Increment; + + function Count return integer is + begin + return Number_Complete; + end Count; + end TC_Tasks_Completed; + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- The Line Driver task would normally be designed to loop continuously + -- creating the messages as input is received. Simulate this + -- but limit it to the required number of dummy messages needed for + -- this test and allow it to terminate at that point. Artificially + -- alternate High and Low priority Credit transactions for this test. + -- + task body Line_Driver is + Current_ID : integer := 1; + Current_Priority : Transaction_Priority := High; + + -- Artificial: number of messages required for this test + type TC_Trans_Range is range 1..6; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + Next_Transaction.Priority := Current_Priority; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + accept Start; -- Wait for trigger from Main + + for Transaction_Numb in TC_Trans_Range loop -- TC: limit the loop + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record := + new Transaction_Record; + begin + if Transaction_Numb = TC_Trans_Range'first then + -- Send the first Credit message + Build_Credit_Record ( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + -- TC: Wait until the first message has been received by the + -- Credit task and it has set the Overload indicator for the + -- Distributor + while not TC_Handshake.First_Message_Arrived loop + delay ImpDef.Minimum_Task_Switch; + end loop; + elsif Transaction_Numb = TC_Trans_Range'last then + -- For this test send the last transaction to the Debit task + -- to improve the mix + Build_Debit_Record( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + else + -- TC: Alternate high and low priority transactions + if Current_Priority = High then + Current_Priority := Low; + else + Current_Priority := High; + end if; + Build_Credit_Record( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end if; + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + + accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + -- For the test check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= Credit_Return or + not This_Transaction.TC_thru_Dist then + Report.Failed ("Expected path not traversed - Credit"); + end if; + TC_Tasks_Completed.Increment; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or + not This_Transaction.TC_thru_Dist then + Report.Failed ("Expected path not traversed - Debit"); + end if; + TC_Debit_Message_Complete.Set_True; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + end Message_Task; + + + + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + task body Credit_Computation is + + Message_Count : integer := 0; + + begin + loop + select + accept Input ( Transaction : acc_Transaction_Record) do + if Distributor.Credit_is_Overloaded + and Transaction.Priority = Low then + -- We should not be getting any Low Priority messages. They + -- should be waiting on the Hold.Wait_for_Underload + -- queue + Report.Failed + ("Credit Task: Low priority transaction during overload"); + end if; + -- Perform the computations required for this transaction + null; -- stub + + -- For the test: + if not Transaction.TC_thru_Dist then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- The following is all Test Control code: + Transaction.Return_Value := Credit_Return; + Message_Count := Message_Count + 1; + -- + -- Now take special action depending on which Message + if Message_Count = 1 then + -- After the first message : + Distributor.Set_Credit_Overloaded; + -- Now flag the Line_Driver that the second and subsequent + -- messages may now be sent + TC_Handshake.Set; + end if; + if Message_Count = 3 then + -- The two high priority transactions created subsequent + -- to the overload have now been processed + Distributor.Clear_Credit_Overloaded; + end if; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + -- + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + null; -- stub + + -- For the test: + if not Transaction.TC_thru_Dist then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + end Debit_Computation; + + +begin + Report.Test ("C954021", "Requeue from one entry body to an entry in" & + " another protected object"); + + Line_Driver.Start; -- Start the test + + + -- Ensure that the message tasks have completed before reporting result + while (TC_Tasks_Completed.Count < TC_Credit_Messages_Expected) + and not TC_Debit_Message_Complete.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + +end C954021; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954022.a b/gcc/testsuite/ada/acats/tests/c9/c954022.a new file mode 100644 index 000000000..5ebff8dcb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954022.a @@ -0,0 +1,351 @@ +-- C954022.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- In an entry body requeue the call to the same entry. Check that the +-- items go to the right queue and that they are placed back on the end +-- of the queue +-- +-- TEST DESCRIPTION: +-- Simulate part of a message handling application where the messages are +-- composed of several segments. The sequence of the segments within the +-- message is specified by Seg_Sequence_No. The segments are handled by +-- different tasks and finally forwarded to an output driver. The +-- segments can arrive in any order but must be assembled into the proper +-- sequence for final output. There is a Sequencer task interposed +-- before the Driver. This takes the segments of the message off the +-- Ordering_Queue and those that are in the right order it sends on to +-- the driver; those that are out of order it places back on the end of +-- the queue. +-- +-- The test just simulates the arrival of the segments at the Sequencer. +-- The task generating the segments handshakes with the Sequencer during +-- the "Await Arrival" phase ensuring that the three segments of a +-- message arrive in REVERSE order (the End-of-Message segment arrives +-- first and the Header last). In the first cycle the sequencer pulls +-- segments off the queue and puts them back on the end till it +-- encounters the header. It checks the sequence of the ones it pulls +-- off in case the segments are being put back on in the wrong part of +-- the queue. Having cycled once through it no longer verifies the +-- sequence - it just executes the "application" code for the correct +-- order for dispatch to the driver. +-- +-- In this simple example no attempt is made to address segments of +-- another message arriving or any other error conditions (such as +-- missing segments, timing etc.) +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 07 Nov 95 SAIC ACVC 2.0.1 +-- +--! + +with Report; +with ImpDef; + +procedure C954022 is + + -- These global Booleans are set when failure conditions inside Protected + -- objects are encountered. Report.Failed cannot be called within + -- the object or a Bounded Error would occur + -- + TC_Failed_1 : Boolean := false; + TC_Failed_2 : Boolean := false; + TC_Failed_3 : Boolean := false; + +begin + + + Report.Test ("C954022", "Check Requeue to the same Protected Entry"); + + declare -- encapsulate the test + + type Segment_Sequence is range 1..8; + Header : constant Segment_Sequence := Segment_Sequence'first; + + type Message_Segment is record + ID : integer; -- Message ID + Seg_Sequence_No : Segment_Sequence; -- Within the message + Segs_In_Message : integer; -- Total segs this message + EOM : Boolean := false; -- true for final msg segment + Alpha : string (1..128); + end record; + type acc_Message_Segment is access Message_Segment; + + task TC_Simulate_Arrival; + + task type Carrier_Task is + entry Input ( Segment : acc_Message_Segment ); + end Carrier_Task; + type acc_Carrier_Task is access Carrier_Task; + + protected Sequencer is + function TC_Arrivals return integer; + entry Input ( Segment : acc_Message_Segment ); + entry Ordering_Queue ( Segment : acc_Message_Segment ); + private + Number_of_Segments_Arrived : integer := 0; + Number_of_Segments_Expected : integer := 0; + Next_Needed : Segment_Sequence := Header; + All_Segments_Arrived : Boolean := false; + Seen_EOM : Boolean := false; + + TC_First_Cycle : Boolean := true; + TC_Expected_Sequence : Segment_Sequence := Header+2; + + end Sequencer; + + + task Output_Driver is + entry Input ( Segment : acc_Message_Segment ); + end Output_Driver; + + + -- Simulate the arrival of three message segments in REVERSE order + -- + task body TC_Simulate_Arrival is + begin + for i in 1..3 loop + declare + -- Create a task for the next message segment + Next_Segment_Task : acc_Carrier_Task := new Carrier_Task; + -- Create a record for the next segment + Next_Segment : acc_Message_Segment := new Message_Segment; + begin + if i = 1 then + -- Build the EOM segment as the first to "send" + Next_Segment.Seg_Sequence_No := Header + 2; + Next_Segment.Segs_In_Message := 3; + Next_Segment.EOM := true; + elsif i = 2 then + -- Wait for the first segment to arrive at the Sequencer + -- before "sending" the second + while Sequencer.TC_Arrivals < 1 loop + delay ImpDef.Minimum_Task_Switch; + end loop; + -- Build the segment + Next_Segment.Seg_Sequence_No := Header +1; + else + -- Wait for the second segment to arrive at the Sequencer + -- before "sending" the third + while Sequencer.TC_Arrivals < 2 loop + delay ImpDef.Minimum_Task_Switch; + end loop; + -- Build the segment. The last segment (in order) to + -- arrive will be the "header" segment + Next_Segment.Seg_Sequence_No := Header; + end if; + -- pass the record to its carrier + Next_Segment_Task.Input ( Next_Segment ); + end; + end loop; + + + exception + when others => + Report.Failed ("Unexpected Exception in TC_Simulate_Arrival"); + end TC_Simulate_Arrival; + + + -- One of these is generated for each message segment and the flow + -- of the segments through the system is controlled by the calls the + -- task makes and the requeues of those calls + -- + task body Carrier_Task is + This_Segment : acc_Message_Segment := new Message_Segment; + begin + accept Input ( Segment : acc_Message_Segment ) do + This_Segment.all := Segment.all; + end Input; + null; --:: stub. Pass the segment around the application as needed + + -- Now output the segment to the Output_Driver. First we have to + -- go through the Sequencer. + Sequencer.Input ( This_Segment ); + exception + when others => + Report.Failed ("Unexpected Exception in Carrier_Task"); + end Carrier_Task; + + -- Store segments on the Ordering_Queue then deliver them in the correct + -- sequence to the Output_Driver. + -- + protected body Sequencer is + + function TC_Arrivals return integer is + begin + return Number_of_Segments_Arrived; + end TC_Arrivals; + + + -- Segments arriving at the Input queue are counted and checked + -- against the total number of segments for the message. They + -- are requeued onto the ordering queue where they are held until + -- all the segments have arrived. + entry Input ( Segment : acc_Message_Segment ) when true is + begin + -- check for EOM, if so get the number of segments in the message + -- Note: in this portion of code no attempt is made to address + -- reset for new message , end conditions, missing segments, + -- segments of a different message etc. + Number_of_Segments_Arrived := Number_of_Segments_Arrived + 1; + if Segment.EOM then + Number_of_Segments_Expected := Segment.Segs_In_Message; + Seen_EOM := true; + end if; + + if Seen_EOM then + if Number_of_Segments_Arrived = Number_of_Segments_Expected then + -- This is the last segment for this message + All_Segments_Arrived := true; -- clear the barrier + end if; + end if; + + requeue Ordering_Queue; + + -- At this exit point the entry queue barriers are evaluated + + end Input; + + + entry Ordering_Queue ( Segment : acc_Message_Segment ) + when All_Segments_Arrived is + begin + + --===================================================== + -- This part is all Test_Control code + + if TC_First_Cycle then + -- Check the order of the original three + if Segment.Seg_Sequence_No /= TC_Expected_Sequence then + -- The segments are not being pulled off in the + -- expected sequence. This could occur if the + -- requeue is not putting them back on the end. + TC_Failed_3 := true; + end if; -- sequence check + -- Decrement the expected sequence + if TC_Expected_Sequence /= Header then + TC_Expected_Sequence := TC_Expected_Sequence - 1; + else + TC_First_Cycle := false; -- This is the Header - the + -- first two segments are + -- back on the queue + end if; -- decrementing + end if; -- first cycle + --===================================================== + + -- And this is the Application code + if Segment.Seg_Sequence_No = Next_Needed then + if Segment.EOM then + Next_Needed := Header; -- reset for next message + -- :: other resets not shown + else + Next_Needed := Next_Needed + 1; + end if; + requeue Output_Driver.Input with abort; + -- set to Report Failed - Requeue did not complete entry body + TC_Failed_1 := true; + else + -- Not the next needed - put it back on the queue + -- NOTE: here we are requeueing to the same entry + requeue Sequencer.Ordering_Queue; + -- set to Report Failed - Requeue did not complete entry body + TC_Failed_2 := true; + end if; + end Ordering_Queue; + end Sequencer; + + + task body Output_Driver is + This_Segment : acc_Message_Segment := new Message_Segment; + + TC_Expected_Sequence : Segment_Sequence := Segment_Sequence'first; + TC_Segment_Total : integer := 0; + TC_Expected_Total : integer := 3; + begin + loop + -- Note: normally we would expect this Accept to be in a select + -- with terminate. For the test we exit the loop on completion + -- to give better control + accept Input ( Segment : acc_Message_Segment ) do + This_Segment.all := Segment.all; + end Input; + + null; --::: stub - output the next segment of the message + + -- The following is all test control code + -- + if This_Segment.Seg_Sequence_No /= TC_Expected_Sequence then + Report.Failed ("Output_Driver: Segment out of sequence"); + end if; + TC_Expected_Sequence := TC_Expected_Sequence + 1; + + -- Now count the number of segments + TC_Segment_Total := TC_Segment_Total + 1; + + -- Check the number and exit loop when complete + -- There must be exactly TC_Expected_Total in number and + -- the last one must be EOM + -- (test will hang if < TC_Expected_Total arrive + -- without EOM) + if This_Segment.EOM then + -- This is the last segment. + if TC_Segment_Total /= TC_Expected_Total then + Report.Failed ("EOM and wrong number of segments"); + end if; + exit; -- the loop and terminate the task + elsif TC_Segment_Total = TC_Expected_Total then + Report.Failed ("No EOM found"); + exit; + end if; + end loop; + exception + when others => + Report.Failed ("Unexpected Exception in Output_Driver"); + end Output_Driver; + + + begin + + null; + + end; -- encapsulation + + if TC_Failed_1 then + Report.Failed ("Requeue did not complete entry body - 1"); + end if; + + if TC_Failed_2 then + Report.Failed ("Requeue did not complete entry body - 2"); + end if; + + if TC_Failed_3 then + Report.Failed ("Sequencer: Segment out of sequence"); + end if; + + Report.Result; + +end C954022; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954023.a b/gcc/testsuite/ada/acats/tests/c9/c954023.a new file mode 100644 index 000000000..bfa69dc60 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954023.a @@ -0,0 +1,558 @@ +-- C954023.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a requeue within a protected entry to a family of entries +-- in a different protected object is queued correctly +-- Call with parameters +-- Requeue with abort +-- +-- TEST DESCRIPTION: +-- One transaction is sent through to check the paths. After processing +-- this, the Credit task sets the "overloaded" indicator. Once this +-- indicator is set the Distributor (a protected object) queues lower +-- priority transactions on a family of queues (Wait_for_Underload) in +-- another protected object using a requeue. The Distributor still +-- delivers high priority transactions. After two more high priority +-- transactions have been processed by the Credit task the artificial +-- test code clears the overload condition to the threshold level that +-- allows only the items on the Medium priority queue of the family to be +-- released. When these have been processed and checked the test code +-- then lowers the priority threshold once again, allowing the Low +-- priority items from the last queue in the family to be released, +-- processed and checked. Note: the High priority queue in the family is +-- not used. +-- +-- This series of tests uses a simulation of a transaction driven +-- processing system. Line Drivers accept input from an external source +-- and build them into transaction records. These records are then +-- encapsulated in message tasks which remain extant for the life of the +-- transaction in the system. The message tasks put themselves on the +-- input queue of a Distributor which, from information in the +-- transaction and/or system load conditions forwards them to other +-- operating tasks. These in turn might forward the transactions to yet +-- other tasks for further action. The routing is, in real life, dynamic +-- and unpredictable at the time of message generation. All rerouting in +-- this model is done by means of requeues. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; +with ImpDef; + +procedure C954023 is + + -- Artificial: number of messages required for this test + subtype TC_Trans_Range is integer range 1..8; + + TC_Credit_Messages_Expected : constant integer + := TC_Trans_Range'Last - 1; + + TC_Debit_Message_Complete : Boolean := false; + + + -- Mechanism for handshaking between tasks + protected TC_PO is + procedure Increment_Tasks_Completed_Count; + function Tasks_Completed_Count return integer; + function First_Message_Has_Arrived return Boolean; + procedure Set_First_Message_Has_Arrived; + private + Number_Complete : integer := 0; + Message_Arrived_Flag : Boolean := false; + end TC_PO; + -- + protected body TC_PO is + procedure Increment_Tasks_Completed_Count is + begin + Number_Complete := Number_Complete + 1; + end Increment_Tasks_Completed_Count; + + function Tasks_Completed_Count return integer is + begin + return Number_Complete; + end Tasks_Completed_Count; + + function First_Message_Has_Arrived return Boolean is + begin + return Message_Arrived_Flag; + end First_Message_Has_Arrived; + + procedure Set_First_Message_Has_Arrived is + begin + Message_Arrived_Flag := true; + end Set_First_Message_Has_Arrived; + + end TC_PO; + +begin + + Report.Test ("C954023", "Requeue from within a protected object" & + " to a family of entries in another protected object"); + + + declare -- encapsulate the test + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + type Transaction_Code is (Credit, Debit); + type App_Priority is (Low, Medium, High); + type Priority_Block is array (App_Priority) of Boolean; + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Priority : App_Priority := High; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Distrib : Boolean := false; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + protected Distributor is + procedure Set_Credit_Overloaded; + procedure Clear_Overload_to_Medium; + procedure Clear_Overload_to_Low; + entry Input (Transaction : acc_Transaction_Record); + private + Credit_Overloaded : Boolean := false; + end Distributor; + + protected Hold is + procedure Release_Medium; + procedure Release_Low; + -- Family of entry queues indexed by App_Priority + entry Wait_for_Underload (App_Priority) + (Transaction : acc_Transaction_Record); + private + Release : Priority_Block := (others => false); + end Hold; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + -- + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + protected body Distributor is + + procedure Set_Credit_Overloaded is + begin + Credit_Overloaded := true; + end Set_Credit_Overloaded; + + procedure Clear_Overload_to_Medium is + begin + Credit_Overloaded := false; + Hold.Release_Medium; -- Release all held messages on Medium + -- priority queue + end Clear_Overload_to_Medium; + + procedure Clear_Overload_to_Low is + begin + Credit_Overloaded := false; + Hold.Release_Low; -- Release all held messages on Low + -- priority queue + end Clear_Overload_to_Low; + + + + entry Input (Transaction : acc_Transaction_Record) when true is + -- barrier is always open + begin + -- Test Control: Set the indicator in the message to show it has + -- passed through the Distributor object + Transaction.TC_thru_Distrib := true; + + -- Pass this transaction on to the appropriate computation + -- task but temporarily hold low-priority transactions under + -- overload conditions + case Transaction.Code is + when Credit => + if Credit_Overloaded and Transaction.Priority /= High then + -- use the appropriate queue in the family + requeue Hold.Wait_for_Underload(Transaction.Priority) + with abort; + else + requeue Credit_Computation.Input with abort; + end if; + when Debit => + requeue Debit_Computation.Input with abort; + end case; + end Input; + end Distributor; + + + -- Low priority Message tasks are held on the Wait_for_Underload queue + -- while the Credit computation system is overloaded. Once the Credit + -- system reached underload send all queued messages immediately + -- + protected body Hold is + + -- Once these are executed the barrier conditions for the entries + -- are evaluated + procedure Release_Medium is + begin + Release(Medium) := true; + end Release_Medium; + -- + procedure Release_Low is + begin + Release(Low) := true; + end Release_Low; + + -- This is a family of entry queues indexed by App_Priority + entry Wait_for_Underload (for AP in App_Priority) + (Transaction : acc_Transaction_Record) + when Release(AP) is + begin + requeue Credit_Computation.Input with abort; + if Wait_for_Underload(AP)'count = 0 then + -- Queue is purged. Set up to hold next batch + Release(AP) := false; + end if; + end Wait_for_Underload; + + end Hold; + + + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- The Line Driver task would normally be designed to loop + -- creating the messages as input is received. Simulate this + -- but limit it to the required number of dummy messages needed for + -- this test and allow it to terminate at that point. Artificially + -- cycle the generation of High medium and Low priority Credit + -- transactions for this test. Send out one final Debit message + -- + task body Line_Driver is + Current_ID : integer := 1; + Current_Priority : App_Priority := High; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + Next_Transaction.Priority := Current_Priority; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + for Transaction_Numb in TC_Trans_Range loop -- TC: limit the loop + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record := + new Transaction_Record; + begin + if Transaction_Numb = TC_Trans_Range'first then + -- Send the first Credit message + Build_Credit_Record ( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + -- TC: Wait until the first message has been received by the + -- Credit task and it has set the Overload indicator for the + -- Distributor + while not TC_PO.First_Message_Has_Arrived loop + delay ImpDef.Minimum_Task_Switch; + end loop; + elsif Transaction_Numb = TC_Trans_Range'last then + -- For this test send the last transaction to the Debit task + -- to improve the mix + Build_Debit_Record( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + else + -- TC: Cycle generation of high medium and low priority + -- transactions + if Current_Priority = High then + Current_Priority := Medium; + elsif + Current_Priority = Medium then + Current_Priority := Low; + else + Current_Priority := High; + end if; + Build_Credit_Record( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end if; + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + + accept Accept_Transaction(In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + -- For the test check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= Credit_Return or + not This_Transaction.TC_thru_Distrib then + Report.Failed ("Expected path not traversed - Credit"); + end if; + TC_PO.Increment_Tasks_Completed_Count; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or + not This_Transaction.TC_thru_Distrib then + Report.Failed ("Expected path not traversed - Debit"); + end if; + TC_Debit_Message_Complete := true; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + end Message_Task; + + + + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + task body Credit_Computation is + + Message_Count : integer := 0; + + begin + loop + select + accept Input ( Transaction : acc_Transaction_Record) do + + -- Perform the computations required for this transaction + null; -- stub + + + -- The following is all Test Control code: + + if not Transaction.TC_thru_Distrib then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- This is checked by the Message_Task: + Transaction.Return_Value := Credit_Return; + + -- Now take special action depending on which Message. + -- Note: The count gives the order in which the messages are + -- arriving at this task NOT the order in which they + -- were originally generated and sent out. + + Message_Count := Message_Count + 1; + + if Message_Count < 4 then + -- This is one of the first three messages which must + -- be High priority because we will set "Overload" after + -- the first, which is known to be High. The lower + -- priority should be waiting on the queues + if Transaction.Priority /= High then + Report.Failed + ("Credit Task: Lower priority trans. during overload"); + end if; + if Message_Count = 1 then + -- After the first message : + Distributor.Set_Credit_Overloaded; + -- Now flag the Line_Driver that the second and + -- subsequent messages may now be sent + TC_PO.Set_First_Message_Has_Arrived; + elsif + Message_Count = 3 then + -- The two high priority transactions created + -- subsequent to the overload have now been processed, + -- release the Medium priority items + Distributor.Clear_Overload_to_Medium; + end if; + elsif Message_Count < 6 then + -- This must be one of the Medium priority messages + if Transaction.Priority /= Medium then + Report.Failed + ("Credit Task: Second group not Medium Priority"); + end if; + if Message_Count = 5 then + -- The two medium priority transactions + -- have now been processed - release the + -- Low priority items + Distributor.Clear_Overload_to_Low; + end if; + elsif Message_Count < TC_Trans_Range'Last then + -- This must be one of the Low priority messages + if Transaction.Priority /= Low then + Report.Failed + ("Credit Task: Third group not Low Priority"); + end if; + else + -- Too many transactions have arrived. Duplicates? + -- the Debit transaction? + Report.Failed + ("Credit Task: Too many transactions"); + end if; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + -- + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + null; -- stub + + -- For the test: + if not Transaction.TC_thru_Distrib then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + end Debit_Computation; + + + begin -- declare + + null; + + end; -- declare (test encapsulation) + + if (TC_PO.Tasks_Completed_Count /= TC_Credit_Messages_Expected) + and not TC_Debit_Message_Complete then + Report.Failed ("Incorrect number of Message Tasks completed"); + end if; + + Report.Result; + +end C954023; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954024.a b/gcc/testsuite/ada/acats/tests/c9/c954024.a new file mode 100644 index 000000000..7f19a8183 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954024.a @@ -0,0 +1,380 @@ +-- C954024.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a call to a protected entry can be requeued to a task +-- entry. Check that the requeue is placed on the correct entry; that the +-- original caller waits for the completion of the requeue and continues +-- after the requeued rendezvous. Check that the requeue does not block. +-- Specifically, check a requeue without abort from a protected entry to +-- an entry in a task. +-- +-- TEST DESCRIPTION: +-- In the Distributor protected object, requeue two successive calls on +-- the entries of two separate target tasks. Each task in each of the +-- paths adds identifying information in the transaction being passed. +-- This information is checked by the Message tasks on completion +-- ensuring that the requeues have been placed on the correct queues. +-- There is an artificial guard on the Credit Task to ensure that the +-- input is queued; this guard is released by the Debit task which +-- handles its input immediately. This ensures that we have one of the +-- requeued items actually queued for later handling and also verifies +-- that the requeuing process (in the protected object) is not blocked. +-- +-- This series of tests uses a simulation of a transaction driven +-- processing system. Line Drivers accept input from an external source +-- and build them into transaction records. These records are then +-- encapsulated in message tasks which remain extant for the life of the +-- transaction in the system. The message tasks put themselves on the +-- input queue of a Distributor object which, from information in the +-- transaction and/or system load conditions forwards them to other +-- operating tasks. These in turn might forward the transactions to yet +-- other tasks for further action. The routing is, in real life, +-- dynamic and unpredictable at the time of message generation. All +-- rerouting in this model is done by means of requeues. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 08 Nov 95 SAIC Fixed reported problems for ACVC 2.0.1 +-- +--! + +with Report; +with ImpDef; +procedure C954024 is + + +begin -- C954024 + + Report.Test ("C954024", "Requeue from protected entry to task entry"); + + declare -- encapsulate the test + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + type Transaction_Code is (Credit, Debit); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Dist : Boolean := false; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + protected Time_Lock is + procedure Credit_Start; + function Credit_Enabled return Boolean; + private + Credit_OK : Boolean := false; + end Time_Lock; + + protected body Time_Lock is + procedure Credit_Start is + begin + Credit_OK := true; + end Credit_Start; + + function Credit_Enabled return Boolean is + begin + return Credit_OK; + end Credit_Enabled; + end Time_Lock; + + + + protected Distributor is + entry Input (Transaction : acc_Transaction_Record); + end Distributor; + -- + -- + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + protected body Distributor is + entry Input (Transaction : acc_Transaction_Record) when true is + -- barrier is always open + begin + -- Test Control: Set the indicator in the message to show it has + -- passed through the Distributor object + Transaction.TC_thru_Dist := true; + + -- Pass this transaction on to the appropriate computation + -- task + case Transaction.Code is + when Credit => + requeue Credit_Computation.Input; + when Debit => + requeue Debit_Computation.Input; + end case; + end Input; + end Distributor; + + + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- NOTE: + -- The Line Driver task would normally be designed to loop continuously + -- creating the messages as input is received. Simulate this + -- but limit it to two dummy messages for this test and allow it + -- to terminate at that point + -- + task body Line_Driver is + Current_ID : integer := 1; + TC_Last_was_for_credit : Boolean := false; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + accept Start; -- Wait for trigger from Main + + for i in 1..2 loop -- arbitrarily limit to two messages for the test + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record + := new Transaction_Record; + begin + if TC_Last_was_for_credit then + Build_Debit_Record ( Next_Transaction ); + else + Build_Credit_Record( Next_Transaction ); + TC_Last_was_for_credit := true; + end if; + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + accept Accept_Transaction + (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + + -- The following is all Test Control Code + + -- Check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= Credit_Return or + This_Transaction.TC_Message_Count /= 1 or + not This_Transaction.TC_thru_Dist then + Report.Failed ("Expected path not traversed"); + end if; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or + not This_Transaction.TC_thru_Dist then + Report.Failed ("Expected path not traversed"); + end if; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + -- + task body Credit_Computation is + Message_Count : integer := 0; + begin + loop + select + when Time_Lock.Credit_enabled => + accept Input ( Transaction : acc_Transaction_Record) do + -- Perform the computations required for this transaction + null; -- stub + + -- For the test: + if not Transaction.TC_thru_Dist then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Credit_Return; + -- one, and only one message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + exit; -- one message is enough + else + delay ImpDef.Clear_Ready_Queue; -- poll + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + -- + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + null; -- stub + + -- For the test: + if not Transaction.TC_thru_Dist then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + -- for the test: once we have completed the only Debit + -- message release the Credit Messages which are queued + -- on the Credit Input queue + Time_Lock.Credit_Start; + + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + end Debit_Computation; + + begin -- declare block + Line_Driver.Start; + end; -- test encapsulation + + Report.Result; + +end C954024; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954025.a b/gcc/testsuite/ada/acats/tests/c9/c954025.a new file mode 100644 index 000000000..c4993f7ed --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954025.a @@ -0,0 +1,237 @@ +-- C954025.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that if the original entry call was a conditional entry call, +-- the call is cancelled if a requeue-with-abort of the call is not +-- selected immediately. +-- Check that if the original entry call was a timed entry call, the +-- expiration time for a requeue-with-abort is the original expiration +-- time. +-- +-- TEST DESCRIPTION: +-- This test declares two tasks: Launch_Control and Mission_Control. +-- Mission_Control instructs Launch_Control to start its countdown +-- and then requeues (with abort) to the Launch_Control.Launch +-- entry. This call to Launch will be accepted at the end of the +-- countdown (if the task is still waiting). +-- The main task does an unconditional, conditional, and timed +-- entry call to Mission_Control and checks to see if the launch +-- was accepted. +-- +-- +-- CHANGE HISTORY: +-- 18 OCT 95 SAIC ACVC 2.1 +-- 10 JUL 96 SAIC Incorporated reviewer's comments. +-- +--! + +with Calendar; use type Calendar.Time; +with Report; +with ImpDef; +procedure C954025 is + Verbose : constant Boolean := False; + Countdown_Amount : constant Duration := 2.0 * Impdef.One_Long_Second; + Plenty_Of_Time : constant Duration := + Countdown_Amount + ImpDef.Clear_Ready_Queue + 1.0 * Impdef.One_Long_Second; + Not_Enough_Time : constant Duration := + Countdown_Amount - 0.5 * Impdef.One_Long_Second; +begin + Report.Test ("C954025", + "Check that if the original entry" & + " call was a conditional or timed entry call, the" & + " expiration time for a requeue with abort is the" & + " original expiration time"); + declare + -- note that the following object is a shared object and its use + -- governed by the rules of 9.10(3,4,8);6.0 + Launch_Accepted : Boolean := False; + + task Launch_Control is + entry Enable_Launch_Control; + entry Start_Countdown (How_Long : Duration); + -- Launch will be accepted if a call is waiting when the countdown + -- reaches 0 + entry Launch; + end Launch_Control; + + task body Launch_Control is + Wait_Amount : Duration := 0.0; + begin + loop + select + accept Enable_Launch_Control do + Launch_Accepted := False; + end Enable_Launch_Control; + or + terminate; + end select; + + accept Start_Countdown (How_Long : Duration) do + Wait_Amount := How_Long; + end Start_Countdown; + + delay Wait_Amount; + + select + accept Launch do + Launch_Accepted := True; + end Launch; + else + null; + -- note that Launch_Accepted is False here + end select; + end loop; + end Launch_Control; + + task Mission_Control is + -- launch will occur if we are given enough time to complete + -- a standard countdown. We will not be rushed! + entry Do_Launch; + end Mission_Control; + + task body Mission_Control is + begin + loop + select + accept Do_Launch do + Launch_Control.Start_Countdown (Countdown_Amount); + requeue Launch_Control.Launch with abort; + end Do_Launch; + or + terminate; + end select; + end loop; + end Mission_Control; + + begin -- test encapsulation + -- unconditional entry call to check the simple case + Launch_Control.Enable_Launch_Control; + Mission_Control.Do_Launch; + if Launch_Accepted then + if Verbose then + Report.Comment ("simple case passed"); + end if; + else + Report.Failed ("simple case"); + end if; + + + -- timed but with plenty of time - delay relative + Launch_Control.Enable_Launch_Control; + select + Mission_Control.Do_Launch; + or + delay Plenty_Of_Time; + if Launch_Accepted then + Report.Failed ("plenty of time timed out after accept (1)"); + end if; + end select; + if Launch_Accepted then + if Verbose then + Report.Comment ("plenty of time case passed (1)"); + end if; + else + Report.Failed ("plenty of time (1)"); + end if; + + + -- timed but with plenty of time -- delay until + Launch_Control.Enable_Launch_Control; + select + Mission_Control.Do_Launch; + or + delay until Calendar.Clock + Plenty_Of_Time; + if Launch_Accepted then + Report.Failed ("plenty of time timed out after accept(2)"); + end if; + end select; + if Launch_Accepted then + if Verbose then + Report.Comment ("plenty of time case passed (2)"); + end if; + else + Report.Failed ("plenty of time (2)"); + end if; + + + -- timed without enough time - delay relative + Launch_Control.Enable_Launch_Control; + select + Mission_Control.Do_Launch; + Report.Failed ("not enough time completed accept (1)"); + or + delay Not_Enough_Time; + end select; + if Launch_Accepted then + Report.Failed ("not enough time (1)"); + else + if Verbose then + Report.Comment ("not enough time case passed (1)"); + end if; + end if; + + + -- timed without enough time - delay until + Launch_Control.Enable_Launch_Control; + select + Mission_Control.Do_Launch; + Report.Failed ("not enough time completed accept (2)"); + or + delay until Calendar.Clock + Not_Enough_Time; + end select; + if Launch_Accepted then + Report.Failed ("not enough time (2)"); + else + if Verbose then + Report.Comment ("not enough time case passed (2)"); + end if; + end if; + + + -- conditional case + Launch_Control.Enable_Launch_Control; + -- make sure Mission_Control is ready to accept immediately + delay ImpDef.Clear_Ready_Queue; + select + Mission_Control.Do_Launch; + Report.Failed ("no time completed accept"); + else + if Verbose then + Report.Comment ("conditional case - else taken"); + end if; + end select; + if Launch_Accepted then + Report.Failed ("no time"); + else + if Verbose then + Report.Comment ("no time case passed"); + end if; + end if; + + end; + + Report.Result; +end C954025; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954026.a b/gcc/testsuite/ada/acats/tests/c9/c954026.a new file mode 100644 index 000000000..9e261247b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954026.a @@ -0,0 +1,269 @@ +-- C954026.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that if the original protected entry call was a conditional +-- entry call, the call is cancelled if a requeue-with-abort of the +-- call is not selected immediately. +-- Check that if the original protected entry call was a timed entry +-- call, the expiration time for a requeue-with-abort is the original +-- expiration time. +-- +-- TEST DESCRIPTION: +-- In this test the main task makes a variety of calls to the protected +-- object Initial_PO. These calls include a simple call, a conditional +-- call, and a timed call. The timed calls include calls with enough +-- time and those with less than the needed amount of time to get through +-- the requeue performed by Initial_PO. +-- Initial_PO requeues its entry call to Final_PO. +-- Final_PO does not accept the requeued call until the protected +-- procedure Ok_To_Take_Requeue is called. +-- A separate task, Delayed_Opener, is used to call Ok_To_Take_Requeue +-- after a delay amount specified by the main task has expired. +-- +-- +-- CHANGE HISTORY: +-- 15 DEC 95 SAIC ACVC 2.1 +-- 10 JUL 96 SAIC Incorporated reviewer comments. +-- 10 OCT 96 SAIC Incorporated fix provided by vendor. +-- +--! + +with Calendar; +use type Calendar.Time; +with Report; +with Impdef; +procedure C954026 is + Verbose : constant Boolean := False; + Final_Po_Reached : Boolean := False; + Allowed_Time : constant Duration := 2.0 * Impdef.One_Long_Second; + Plenty_Of_Time : constant Duration := + Allowed_Time + Impdef.Clear_Ready_Queue + 1.0 * Impdef.One_Long_Second; + Not_Enough_Time : constant Duration := Allowed_Time - 0.5 * Impdef.One_Long_Second; +begin + Report.Test ("C954026", + "Check that if the original entry" & + " call was a conditional or timed entry call," & + " the expiration time for a requeue with" & + " abort to a protected" & + " entry is the original expiration time"); + declare + + protected Initial_Po is + entry Start_Here; + end Initial_Po; + + protected Final_Po is + entry Requeue_Target; + procedure Ok_To_Take_Requeue; + procedure Close_Requeue; + private + Open : Boolean := False; + end Final_Po; + + -- the Delayed_Opener task is used to notify Final_PO that it can + -- accept the Requeue_Target entry. + task Delayed_Opener is + entry Start_Timer (Amt : Duration); + entry Cancel_Timer; + end Delayed_Opener; + + task body Delayed_Opener is + Wait_Amt : Duration; + begin + loop + accept Start_Timer (Amt : Duration) do + Wait_Amt := Amt; + end Start_Timer; + exit when Wait_Amt < 0.0; + if Verbose then + Report.Comment ("Timer started"); + end if; + select + accept Cancel_Timer do + Final_Po.Close_Requeue; + end Cancel_Timer; + or + delay Wait_Amt; + Final_Po.Ok_To_Take_Requeue; + accept Cancel_Timer do + Final_Po.Close_Requeue; + end Cancel_Timer; + end select; + end loop; + exception + when others => + Report.Failed ("exception in Delayed_Opener"); + end Delayed_Opener; + + protected body Initial_Po is + entry Start_Here when True is + begin + Final_Po_Reached := False; + requeue Final_Po.Requeue_Target with abort; + end Start_Here; + end Initial_Po; + + protected body Final_Po is + entry Requeue_Target when Open is + begin + Open := False; + Final_Po_Reached := True; + end Requeue_Target; + + procedure Ok_To_Take_Requeue is + begin + Open := True; + end Ok_To_Take_Requeue; + + procedure Close_Requeue is + begin + Open := False; + end Close_Requeue; + end Final_Po; + + begin -- test encapsulation + -- unconditional entry call to check the simple case + Delayed_Opener.Start_Timer (0.0); + Initial_Po.Start_Here; + if Final_Po_Reached then + if Verbose then + Report.Comment ("simple case passed"); + end if; + else + Report.Failed ("simple case"); + end if; + Delayed_Opener.Cancel_Timer; + + + -- timed but with plenty of time - delay relative + Delayed_Opener.Start_Timer (Allowed_Time); + select + Initial_Po.Start_Here; + or + delay Plenty_Of_Time; + Report.Failed ("plenty of time timed out (1)"); + if Final_Po_Reached then + Report.Failed ( + "plenty of time timed out after accept (1)"); + end if; + end select; + if Final_Po_Reached then + if Verbose then + Report.Comment ("plenty of time case passed (1)"); + end if; + else + Report.Failed ("plenty of time (1)"); + end if; + Delayed_Opener.Cancel_Timer; + + + -- timed but with plenty of time -- delay until + Delayed_Opener.Start_Timer (Allowed_Time); + select + Initial_Po.Start_Here; + or + delay until Calendar.Clock + Plenty_Of_Time; + Report.Failed ("plenty of time timed out (2)"); + if Final_Po_Reached then + Report.Failed ( + "plenty of time timed out after accept(2)"); + end if; + end select; + if Final_Po_Reached then + if Verbose then + Report.Comment ("plenty of time case passed (2)"); + end if; + else + Report.Failed ("plenty of time (2)"); + end if; + Delayed_Opener.Cancel_Timer; + + + -- timed without enough time - delay relative + Delayed_Opener.Start_Timer (Allowed_Time); + select + Initial_Po.Start_Here; + Report.Failed ("not enough time completed accept (1)"); + or + delay Not_Enough_Time; + end select; + if Final_Po_Reached then + Report.Failed ("not enough time (1)"); + else + if Verbose then + Report.Comment ("not enough time case passed (1)"); + end if; + end if; + Delayed_Opener.Cancel_Timer; + + + -- timed without enough time - delay until + Delayed_Opener.Start_Timer (Allowed_Time); + select + Initial_Po.Start_Here; + Report.Failed ("not enough time completed accept (2)"); + or + delay until Calendar.Clock + Not_Enough_Time; + end select; + if Final_Po_Reached then + Report.Failed ("not enough time (2)"); + else + if Verbose then + Report.Comment ("not enough time case passed (2)"); + end if; + end if; + Delayed_Opener.Cancel_Timer; + + + -- conditional case + Delayed_Opener.Start_Timer (Allowed_Time); + select + Initial_Po.Start_Here; + Report.Failed ("no time completed accept"); + else + if Verbose then + Report.Comment ("conditional case - else taken"); + end if; + end select; + if Final_Po_Reached then + Report.Failed ("no time"); + else + if Verbose then + Report.Comment ("no time case passed"); + end if; + end if; + Delayed_Opener.Cancel_Timer; + + -- kill off the Delayed_Opener task + Delayed_Opener.Start_Timer (-10.0); + + exception + when others => + Report.Failed ("exception in main"); + end; + + Report.Result; +end C954026; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954a01.a b/gcc/testsuite/ada/acats/tests/c9/c954a01.a new file mode 100644 index 000000000..3ea545a8f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954a01.a @@ -0,0 +1,262 @@ +-- C954A01.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that if a task requeued without abort on a protected entry queue +-- is aborted, the abort is deferred until the entry call completes, +-- after which the task becomes completed. +-- +-- TEST DESCRIPTION: +-- Declare a protected type which simulates a printer device driver +-- (foundation code). +-- +-- Declare a task which simulates a printer server for multiple printers. +-- +-- For the protected type, declare an entry with a barrier that is set +-- false by a protected procedure (which simulates starting a print job +-- on the printer), and is set true by a second protected procedure (which +-- simulates a handler called when the printer interrupts, indicating +-- that printing is done). +-- +-- For the task, declare an entry whose corresponding accept statement +-- contains a call to first protected procedure of the protected type +-- (which sets the barrier of the protected entry to false), followed by +-- a requeue with abort to the protected entry. Declare a second entry +-- which does nothing. +-- +-- Declare a "requesting" task which calls the printer server task entry +-- (and thus executes the requeue). Attempt to abort the requesting +-- task. Verify that it is not aborted. Call the second protected +-- procedure of the protected type (the interrupt handler) and verify that +-- the protected entry completes for the requesting task. Verify that +-- the requesting task is then aborted. +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- F954A00.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 10 Oct 96 SAIC Added pragma elaborate. +-- +--! + +package C954A01_0 is -- Printer server abstraction. + + -- Simulate a system with multiple printers. The entry Print requests + -- that data be printed on the next available printer. The entry call + -- is accepted when a printer is available, and completes when printing + -- is done. + + + task Printer_Server is + entry Print (File_Name : String); -- Test the requeue statement. + entry Verify_Results; -- Artifice for test purposes. + end Printer_Server; + +end C954A01_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +with F954A00; -- Printer device abstraction. +use F954A00; +pragma Elaborate(F954A00); + +package body C954A01_0 is -- Printer server abstraction. + + task body Printer_Server is + Printers_Busy : Boolean := True; + Index : Printer_ID := 1; + Print_Accepted : Boolean := False; + begin + + loop + -- Wait for a printer to become available: + + while Printers_Busy loop + Printers_Busy := False; -- Exit loop if + -- entry accepted. + select + Printer(Index).Done_Printing; -- Accepted immed. + -- when printer is + -- available. + else + Index := 1 + (Index mod Number_Of_Printers);-- Entry not immed. + Printers_Busy := True; -- accepted; keep + end select; -- looping. + end loop; + -- Value of Index + -- at loop exit + -- identifies the + -- avail. printer. + + -- Wait for a print request or terminate: + + select + accept Print (File_Name : String) do + Print_Accepted := True; -- Allow + -- Verify_Results + -- to be accepted. + + Printer(Index).Start_Printing (File_Name); -- Begin printing on + -- the available + -- -- -- printer. + -- Requeue is tested here -- + -- -- + -- Requeue caller so + requeue Printer(Index).Done_Printing; -- server task free + -- to accept other + end Print; -- requests. + or + -- Guard ensures that Verify_Results cannot be accepted + -- until after Print has been accepted. This avoids a + -- race condition in the main program. + + when Print_Accepted => accept Verify_Results; -- Artifice for + -- testing purposes. + or + terminate; + end select; + + -- Allow other tasks to get control + delay ImpDef.Long_Minimum_Task_Switch; + + end loop; + + exception + when others => + Report.Failed ("Exception raised in Printer_Server task"); + end Printer_Server; + + +end C954A01_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +with F954A00; -- Printer device abstraction. +with C954A01_0; -- Printer server abstraction. + +use C954A01_0; +use F954A00; + +procedure C954A01 is + + Long_Enough : constant Duration := ImpDef.Long_Switch_To_New_Task; + + --==============================================-- + + task Print_Request; -- Send a print request. + + task body Print_Request is + My_File : constant String := "MYFILE.DAT"; + begin + Printer_Server.Print (My_File); -- Invoke requeue statement. + Report.Failed ("Task continued execution following entry call"); + exception + when others => + Report.Failed ("Exception raised in Print_Request task"); + end Print_Request; + + --==============================================-- + +begin -- Main program. + + Report.Test ("C954A01", "Requeue without abort - check that the abort " & + "is deferred until after the rendezvous completes. (Task to PO)"); + + -- To pass this test, the following must be true: + -- + -- (A) The abort of Print_Request is deferred until after the + -- Done_Printing entry body completes. + -- (B) Print_Request aborts after the Done_Printing entry call + -- completes. + -- + -- Call the entry Verify_Results. The entry call will not be accepted + -- until after Print_Request has been requeued to Done_Printing. + + Printer_Server.Verify_Results; -- Accepted after Print_Request is + -- requeued to Done_Printing. + + -- Simulate an application which needs access to the printer within + -- a specified time, and which aborts the current printer job if time + -- runs out. + + select + Printer(1).Done_Printing; -- Wait for printer to come free. + or + delay Long_Enough; -- Print job took too long. + abort Print_Request; -- Abort print job. + end select; + + Printer_Server.Verify_Results; -- Abortion completion point: force + -- abort to complete (if it's going + -- to). + + -- Verify that the Done_Printing entry body has not yet completed, + -- and thus that Print_Request has not been aborted. + + if Printer(1).Is_Done then + Report.Failed ("Target entry of requeue executed prematurely"); + elsif Print_Request'Terminated then + Report.Failed ("Caller was aborted before entry was complete"); + else + + Printer(1).Handle_Interrupt; -- Simulate a printer interrupt, + -- signaling that printing is + -- done. + + -- The Done_Printing entry body will complete before the next protected + -- action is called (Printer(1).Is_Done). Verify (A) and (B): that the + -- Print_Request is aborted. + + Printer_Server.Verify_Results; -- Abortion completion point: force + -- Print_Request abort to complete. + + if not Printer(1).Is_Done then + Report.Failed ("Target entry of requeue did not complete"); + end if; + + if not Print_Request'Terminated then + Report.Failed ("Task not aborted following completion of entry call"); + abort Print_Request; -- Try to kill hung task. + end if; + + end if; + + Report.Result; + +end C954A01; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954a02.a b/gcc/testsuite/ada/acats/tests/c9/c954a02.a new file mode 100644 index 000000000..7d61aea8c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954a02.a @@ -0,0 +1,259 @@ +-- C954A02.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that if a task requeued with abort on a protected entry queue +-- is aborted, the protected entry call is canceled and the aborted +-- task becomes completed. +-- +-- TEST DESCRIPTION: +-- Declare a protected type which simulates a printer device driver +-- (foundation code). +-- +-- Declare a task which simulates a printer server for multiple printers. +-- +-- For the protected type, declare an entry with a barrier that is set +-- false by a protected procedure (which simulates starting a print job +-- on the printer), and is set true by a second protected procedure (which +-- simulates a handler called when the printer interrupts, indicating +-- that printing is done). +-- +-- For the task, declare an entry whose corresponding accept statement +-- contains a call to first protected procedure of the protected type +-- (which sets the barrier of the protected entry to false), followed by +-- a requeue with abort to the protected entry. Declare a second entry +-- which does nothing. +-- +-- Declare a "requesting" task which calls the printer server task entry +-- (and thus executes the requeue). Attempt to abort the requesting +-- task. Verify that it is aborted, that the requeued entry call is +-- canceled, and that the corresponding entry body is not executed. +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- F954A00.A +-- +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 10 Oct 96 SAIC Added pragma elaborate +-- +--! + +package C954A02_0 is -- Printer server abstraction. + + -- Simulate a system with multiple printers. The entry Print requests + -- that data be printed on the next available printer. The entry call + -- is accepted when a printer is available, and completes when printing + -- is done. + + + task Printer_Server is + entry Print (File_Name : String); -- Test the requeue statement. + entry Verify_Results; -- Artifice for test purposes. + end Printer_Server; + +end C954A02_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +with F954A00; -- Printer device abstraction. +use F954A00; +pragma Elaborate(F954a00); + +package body C954A02_0 is -- Printer server abstraction. + + task body Printer_Server is + Printers_Busy : Boolean := True; + Index : Printer_ID := 1; + Print_Accepted : Boolean := False; + begin + + loop + -- Wait for a printer to become available: + + while Printers_Busy loop + Printers_Busy := False; -- Exit loop if + -- entry accepted. + select + Printer(Index).Done_Printing; -- Accepted immed. + -- when printer is + -- available. + else + Index := 1 + (Index mod Number_Of_Printers);-- Entry not immed. + Printers_Busy := True; -- accepted; keep + end select; -- looping. + + -- Allow other task to get control + delay ImpDef.Minimum_Task_Switch; + + end loop; -- Value of Index + -- at loop exit + -- identifies the + -- avail. printer. + + -- Wait for a print request or terminate: + + select + accept Print (File_Name : String) do + Print_Accepted := True; -- Allow + -- Verify_Results + -- to be accepted. + + Printer(Index).Start_Printing (File_Name); -- Begin printing on + -- the available + -- -- -- printer. + -- Requeue is tested here -- + -- -- + -- Requeue caller so + requeue Printer(Index).Done_Printing -- server task free + with abort; -- to accept other + end Print; -- requests. + or + -- Guard ensures that Verify_Results cannot be accepted + -- until after Print has been accepted. This avoids a + -- race condition in the main program. + + when Print_Accepted => accept Verify_Results; -- Artifice for + -- testing purposes. + or + terminate; + end select; + + end loop; + + exception + when others => + Report.Failed ("Exception raised in Printer_Server task"); + end Printer_Server; + + +end C954A02_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +with F954A00; -- Printer device abstraction. +with C954A02_0; -- Printer server abstraction. + +use C954A02_0; +use F954A00; + +procedure C954A02 is + + -- Length of time which simulates a very long process + Long_Enough : constant Duration := ImpDef.Clear_Ready_Queue; + + --==============================================-- + + task Print_Request; -- Send a print request. + + task body Print_Request is + My_File : constant String := "MYFILE.DAT"; + begin + Printer_Server.Print (My_File); -- Invoke requeue statement. + Report.Failed ("Task continued execution following entry call"); + exception + when others => + Report.Failed ("Exception raised in Print_Request task"); + end Print_Request; + + --==============================================-- + +begin -- Main program. + + Report.Test ("C954A02", "Abort a requeue on a Protected entry"); + + -- To pass this test, the following must be true: + -- + -- (A) The abort of Print_Request takes place immediately. + -- (B) The Done_Printing entry call is canceled, and the corresponding + -- entry body is not executed. + -- + -- Call the entry Verify_Results. The entry call will not be accepted + -- until after Print_Request has been requeued to Done_Printing. + + Printer_Server.Verify_Results; -- Accepted after Print_Request is + -- requeued to Done_Printing. + + -- Verify that the Done_Printing entry call has not been completed. + -- + if Printer(1).Is_Done then + Report.Failed ("Target entry of requeue executed prematurely"); + else + + -- Simulate an application which needs access to the printer within + -- a specified time, and which aborts the current printer job if time + -- runs out. + + select + Printer(1).Done_Printing; -- Wait for printer to come free. + or + delay Long_Enough; -- Print job took too long. + abort Print_Request; -- Abort print job. + end select; + + Printer_Server.Verify_Results; -- Abortion completion point: force + -- Print_Request abort to complete. + + -- Verify (A): that Print_Request has been aborted. + -- Note: the test will hang if the task as not been aborted + -- + while not Print_Request'Terminated loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- Verify (B): that the Done_Printing entry call was canceled, and + -- the corresponding entry body was not executed. + -- + -- Set the barrier of the entry to true, then check that the entry + -- body is not executed. If the entry call is NOT canceled, the + -- entry body will execute when the barrier is set true. + + Printer(1).Handle_Interrupt; -- Simulate a printer interrupt, + -- signaling that printing is + -- done. + if Printer(1).Is_Done then + Report.Failed ("Entry call was not canceled"); + end if; + + + end if; + + + Report.Result; + +end C954A02; diff --git a/gcc/testsuite/ada/acats/tests/c9/c954a03.a b/gcc/testsuite/ada/acats/tests/c9/c954a03.a new file mode 100644 index 000000000..13d21311c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c954a03.a @@ -0,0 +1,322 @@ +-- C954A03.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that a requeue statement in an accept_statement with +-- parameters may requeue the entry call to a protected entry with no +-- parameters. Check that, if the call is queued on the new entry's +-- queue, the original caller remains blocked after the requeue, but +-- the accept_statement containing the requeue is completed. +-- +-- Note that this test uses a requeue "with abort," although it does not +-- check that such a requeued caller can be aborted; that feature is +-- tested elsewhere. +-- +-- TEST DESCRIPTION: +-- Declare a protected type which simulates a printer device driver +-- (foundation code). +-- +-- Declare a task which simulates a printer server for multiple printers. +-- +-- For the protected type, declare an entry with a barrier that is set +-- false by a protected procedure (which simulates starting a print job +-- on the printer), and is set true by a second protected procedure (which +-- simulates a handler called when the printer interrupts, indicating +-- that printing is done). +-- +-- For the task, declare an entry whose corresponding accept statement +-- contains a call to first protected procedure of the protected type +-- (which sets the barrier of the protected entry to false), followed by +-- a requeue with abort to the protected entry. Declare a second entry +-- which does nothing. +-- +-- Declare a "requesting" task which calls the printer server task entry +-- (and thus executes the requeue). Verify that, following the requeue, +-- the requesting task remains blocked. Call the second entry of the +-- printer server task (the acceptance of this entry call verifies that +-- the requeue statement completed the entry call by the requesting task. +-- Call the second protected procedure of the protected type (the +-- interrupt handler) and verify that the protected entry completes for +-- the requesting task (which verifies that the requeue statement queued +-- the first task object to the protected entry). +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- F954A00.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 10 Oct 96 SAIC Added pragma elaborate. +-- +--! + +package C954A03_0 is -- Printer server abstraction. + + -- Simulate a system with multiple printers. The entry Print requests + -- that data be printed on the next available printer. The entry call + -- is accepted when a printer is available, and completes when printing + -- is done. + + task Printer_Server is + entry Print (File_Name : String); -- Test the requeue statement. + entry Verify_Results; -- Artifice for test purposes. + end Printer_Server; + +end C954A03_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +with F954A00; -- Printer device abstraction. +use F954A00; +pragma Elaborate(F954a00); + +package body C954A03_0 is -- Printer server abstraction. + + + task body Printer_Server is + Printers_Busy : Boolean := True; + Index : Printer_ID := 1; + Print_Accepted : Boolean := False; + begin + + loop + -- Wait for a printer to become available: + + while Printers_Busy loop + Printers_Busy := False; -- Exit loop if + -- entry accepted. + select + Printer(Index).Done_Printing; -- Accepted immed. + -- when printer is + -- available. + else + Index := 1 + (Index mod Number_Of_Printers);-- Entry not immed. + Printers_Busy := True; -- accepted; keep + end select; -- looping. + + -- Allow other tasks to get control + delay ImpDef.Minimum_Task_Switch; + + end loop; + -- Value of Index + -- at loop exit + -- identifies the + -- avail. printer. + + -- Wait for a print request or terminate: + + select + accept Print (File_Name : String) do + Print_Accepted := True; -- Allow + -- Verify_Results + -- to be accepted. + + Printer(Index).Start_Printing (File_Name); -- Begin printing on + -- the available + -- -- -- printer. + -- Requeue is tested here -- + -- -- + -- Requeue caller so + requeue Printer(Index).Done_Printing -- server task free + with abort; -- to accept other + end Print; -- requests. + or + -- Guard ensures that Verify_Results cannot be accepted + -- until after Print has been accepted. This avoids a + -- race condition in the main program. + + when Print_Accepted => accept Verify_Results; -- Artifice for + -- testing purposes. + or + terminate; + end select; + + end loop; + + exception + when others => + Report.Failed ("Exception raised in Printer_Server task"); + end Printer_Server; + + +end C954A03_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +with F954A00; -- Printer device abstraction. +with C954A03_0; -- Printer server abstraction. + +use C954A03_0; +use F954A00; + +procedure C954A03 is + + Long_Enough : constant Duration := ImpDef.Clear_Ready_Queue; + + + --==============================================-- + + Task_Completed : Boolean := False; -- Testing flag. + + protected Interlock is -- Artifice for test purposes. + entry Wait; -- Wait for lock to be released. + procedure Release; -- Release the lock. + private + Locked : Boolean := True; + end Interlock; + + + protected body Interlock is + + entry Wait when not Locked is -- Calls are queued until after + -- -- Release is called. + begin + Task_Completed := True; + end Wait; + + procedure Release is -- Called by Print_Request. + begin + Locked := False; + end Release; + + end Interlock; + + --==============================================-- + + task Print_Request is -- Send a print request. + end Print_Request; + + task body Print_Request is + My_File : constant String := "MYFILE.DAT"; + begin + Printer_Server.Print (My_File); -- Invoke requeue statement. + Interlock.Release; -- Allow main to continue. + exception + when others => + Report.Failed ("Exception raised in Print_Request task"); + end Print_Request; + + --==============================================-- + +begin -- Main program. + + Report.Test ("C954A03", "Requeue from an Accept with parameters" & + " to a Protected Entry without parameters"); + + -- To pass this test, the following must be true: + -- + -- (A) The Print entry call made by the task Print_Request must be + -- completed by the requeue statement. + -- (B) Print_Request must remain blocked following the requeue. + -- (C) Print_Request must be queued on the Done_Printing queue of + -- Printer(1). + -- (D) Print_Request must continue execution after Done_Printing is + -- complete. + -- + -- First, verify (A): that the Print entry call is complete. + -- + -- Call the entry Verify_Results. If the requeue statement completed the + -- entry call to Print, the entry call to Verify_Results should be + -- accepted. Since the main will hang if this is NOT the case, make this + -- a timed entry call. + + select + Printer_Server.Verify_Results; -- Accepted if requeue completed + -- entry call to Print. + or + delay Long_Enough; -- Time out otherwise. + Report.Failed ("Requeue did not complete entry call"); + end select; + + -- Now verify (B): that Print_Request remains blocked following the + -- requeue. Also verify that Done_Printing (the entry to which + -- Print_Request should have been queued) has not yet executed. + + if Printer(1).Is_Done then + Report.Failed ("Target entry of requeue executed prematurely"); + elsif Print_Request'Terminated then + Report.Failed ("Caller did not remain blocked after the requeue"); + else + + -- Verify (C): that Print_Request is queued on the + -- Done_Printing queue of Printer(1). + -- + -- Set the barrier for Printer(1).Done_Printing to true. Check + -- that the Done flag is updated and that Print_Request terminates. + + Printer(1).Handle_Interrupt; -- Simulate a printer interrupt, + -- signaling that printing is + -- done. + + -- The Done_Printing entry body will complete before the next + -- protected action is called (Printer(1).Is_Done). + + if not Printer(1).Is_Done then + Report.Failed ("Caller was not requeued on target entry"); + end if; + + -- Finally, verify (D): that Print_Request continues after Done_Printing + -- completes. + -- + -- After Done_Printing completes, there is a potential race condition + -- between the main program and Print_Request. The protected object + -- Interlock is provided to ensure that the check of whether + -- Print_Request continued is made *after* it has had a chance to do so. + -- The main program waits until the statement in Print_Request following + -- the requeue-causing statement has executed, then checks to see + -- whether Print_Request did in fact continue executing. + -- + -- Note that the test will hang here if Print_Request does not continue + -- executing following the completion of the requeued entry call. + + Interlock.Wait; -- Wait until Print_Request is + -- done. + if not Task_Completed then + Report.Failed ("Caller remained blocked after target " & + "entry released"); + end if; + + -- Wait for Print_Request to finish before calling Report.Result. + while not Print_Request'Terminated loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + end if; + + Report.Result; + +end C954A03; diff --git a/gcc/testsuite/ada/acats/tests/c9/c960001.a b/gcc/testsuite/ada/acats/tests/c9/c960001.a new file mode 100644 index 000000000..4eaa1f49f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c960001.a @@ -0,0 +1,164 @@ +-- C960001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Confirm that a simple Delay Until statement is performed. Check +-- that the delay does not complete before the requested time and that it +-- does complete thereafter +-- +-- TEST DESCRIPTION: +-- Simulate a task that sends a "pulse" at regular intervals. The Delay +-- Until statement is used to avoid accumulated drift. For the +-- test, we expect the delay to return very close to the requested time; +-- we use an additional Pulse_Time_Delta for the limit. The test +-- driver (main) artificially limits the number of iterations by setting +-- the Stop_Pulse Boolean after a small number. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 15 Nov 95 SAIC Fixed global variable problem for ACVC 2.0.1 +-- +--! + +with Report; +with Ada.Calendar; +with ImpDef; + +procedure C960001 is + +begin + + Report.Test ("C960001", "Simple Delay Until"); + + declare -- To get the Report.Result after all has completed + + function "+" (Left : Ada.Calendar.Time; Right: Duration) + return Ada.Calendar.Time renames Ada.Calendar."+"; + function "<" (Left, Right : Ada.Calendar.Time) + return Boolean renames Ada.Calendar."<"; + function ">" (Left, Right : Ada.Calendar.Time) + return Boolean renames Ada.Calendar.">"; + + TC_Loop_Count : integer range 0..4 := 0; + + + -- control over stopping tasks + protected Control is + procedure Stop_Now; + function Stop return Boolean; + private + Halt : Boolean := False; + end Control; + + protected body Control is + procedure Stop_Now is + begin + Halt := True; + end Stop_Now; + + function Stop return Boolean is + begin + return Halt; + end Stop; + end Control; + + task Pulse_Task is + entry Trigger; + end Pulse_Task; + + + -- Task to synchronize all qualified receivers. + -- The entry Trigger starts the synchronization; Control.Stop + -- becoming true terminates the task. + -- + task body Pulse_Task is + + Pulse_Time : Ada.Calendar.Time; + + Pulse_Time_Delta : duration := ImpDef.Clear_Ready_Queue; + + TC_Last_Time : Ada.Calendar.Time; + TC_Current : Ada.Calendar.Time; + + + -- This routine transmits a synchronizing "pulse" to + -- all receivers + procedure Pulse is + begin + null; -- Stub + Report.Comment (".......PULSE........"); + end Pulse; + + begin + accept Trigger; + + Pulse_Time := Ada.Calendar.Clock + Pulse_Time_Delta; + TC_Last_Time := Pulse_Time; + + while not Control.Stop loop + delay until Pulse_Time; + Pulse; + + -- Calculate time for next pulse. Note: this is based on the + -- last pulse time, not the time we returned from the delay + -- + Pulse_Time := Pulse_Time + Pulse_Time_Delta; + + -- Test Control: + TC_Current := Ada.Calendar.Clock; + if TC_Current < TC_Last_Time then + Report.Failed ("Delay expired before requested time"); + end if; + if TC_Current > Pulse_Time then + Report.Failed ("Delay too long"); + end if; + TC_Last_Time := Pulse_Time; + TC_Loop_Count := TC_Loop_Count +1; + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Pulse_Task"); + end Pulse_Task; + + + + begin -- declare + + Pulse_Task.Trigger; -- Start test + + -- Artificially limit the number of iterations + while TC_Loop_Count < 3 loop + delay ImpDef.Minimum_Task_Switch; + end loop; + -- + Control.Stop_Now; -- End test + + end; -- declare + + Report.Result; + +end C960001; diff --git a/gcc/testsuite/ada/acats/tests/c9/c960002.a b/gcc/testsuite/ada/acats/tests/c9/c960002.a new file mode 100644 index 000000000..06edaf0c9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c960002.a @@ -0,0 +1,171 @@ +-- C960002.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the simple "delay until" when the request time is "now" and +-- also some time already in the past is obeyed and returns immediately +-- +-- TEST DESCRIPTION: +-- Simulate a task that sends a "pulse" at regular intervals. The Delay +-- Until statement is used to avoid accumulated drift. In this test +-- three simple situations simulating the start of drift are used: the +-- next pulse being called for at the normal time, the next pulse being +-- called for at exactly the current time and then at some time which has +-- already past. We assume the delay is within a While Loop and, to +-- simplify the test, we "unfold" the While Loop and execute the Delays +-- in a serial fashion. This loop is shown in test C960001. +-- It is not possible to test the actual immediacy of the expiration. We +-- can only check that it returns in a "reasonable" time. In this case +-- we check that it expires before the next "pulse" should have been +-- issued. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; +with ImpDef; + +with Ada.Calendar; +with System; + +procedure C960002 is + +begin + + Report.Test ("C960002", "Simple Delay Until with requested time being" & + " ""now"" and time already in the past"); + + declare -- To get the Report.Result after all has completed + + function "+" (Left : Ada.Calendar.Time; Right: Duration) + return Ada.Calendar.Time renames Ada.Calendar."+"; + function "-" (Left : Ada.Calendar.Time; Right: Duration) + return Ada.Calendar.Time renames Ada.Calendar."-"; + function "-" (Left, Right : Ada.Calendar.Time) + return duration renames Ada.Calendar."-"; + function ">" (Left, Right : Ada.Calendar.Time) + return Boolean renames Ada.Calendar.">"; + + + task Pulse_Task is + entry Trigger; + end Pulse_Task; + + + -- Task to synchronize all qualified receivers. + -- The entry Trigger starts the synchronization. + -- + task body Pulse_Task is + Pulse_Time : Ada.Calendar.Time; + Pulse_Time_Delta : constant duration := ImpDef.Clear_Ready_Queue; + + + + TC_Time_Back : Ada.Calendar.Time; + + + -- This routine transmits a synchronizing "pulse" to + -- all receivers + procedure Pulse is + begin + null; -- Stub + Report.Comment (".......PULSE........"); + end Pulse; + + begin + accept Trigger; + Pulse; + --------------- + -- normal calculation for "next" + Pulse_Time := Ada.Calendar.Clock + Pulse_Time_Delta; + + -- TC: unfold the "while" loop in C960001. Four passes through + -- the loop are shown + + delay until Pulse_Time; + + Pulse; + --------------- + -- TC: the normal calculation for "next" would be + -- Pulse_Time := Pulse_Time + Pulse_Time_Delta; + -- Instead of this normal pulse time calculation simulate + -- the new pulse time to be exactly "now" (or, as exactly as + -- we can) + Pulse_Time := Ada.Calendar.Clock; + delay until Ada.Calendar.Clock; + + TC_Time_Back := Ada.Calendar.Clock; + + -- Now check for reasonableness + if TC_Time_Back > Pulse_Time + Pulse_Time_Delta then + Report.Failed + ("""Now"" delayed for more than Pulse_Time_Delta - A"); + end if; + Pulse; + --------------- + -- normal calculation for "next" would be + Pulse_Time := Pulse_Time + Pulse_Time_Delta; + + -- TC: Instead of this, simulate the new calculated pulse time + -- being already past + Pulse_Time := Ada.Calendar.Clock - System.Tick; + delay until Pulse_Time; + + TC_Time_Back := Ada.Calendar.Clock; + + -- Now check for reasonableness + if TC_Time_Back > Pulse_Time + Pulse_Time_Delta then + Report.Failed + ("""Now"" delayed for more than Pulse_Time_Delta - B"); + end if; + Pulse; + --------------- + -- normal calculation for "next" + Pulse_Time := Pulse_Time + Pulse_Time_Delta; + -- Now simulate getting back into synch + delay until Pulse_Time; + Pulse; + --------------- + -- This would be the end of the "while" loop + + exception + when others => + Report.Failed ("Unexpected exception in Pulse_Task"); + end Pulse_Task; + + + + begin -- declare + + Pulse_Task.Trigger; -- Start test + + end; -- declare + + Report.Result; + +end C960002; diff --git a/gcc/testsuite/ada/acats/tests/c9/c960004.a b/gcc/testsuite/ada/acats/tests/c9/c960004.a new file mode 100644 index 000000000..f394aab66 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c960004.a @@ -0,0 +1,206 @@ +-- C960004.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- With the triggering statement being a delay and with the Asynchronous +-- Select statement being in a tasking situation complete the abortable +-- part before the delay expires. Check that the delay is cancelled +-- and that the optional statements in the triggering part are not +-- executed. +-- +-- TEST DESCRIPTION: +-- Simulate the creation of a carrier task to control the output of +-- a message via a line driver. If the message sending process is +-- not complete (the completion of the rendezvous) within a +-- specified time the carrier task is designed to take corrective action. +-- Use an asynchronous select to control the timing; arrange that +-- the abortable part (the rendezvous) completes almost immediately. +-- Check that the optional statements are not executed and that the +-- test completes well before the time of the trigger delay request thus +-- showing that it has been cancelled. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +with Report; +with Ada.Calendar; + +procedure C960004 is + + function "-" (Left, Right : Ada.Calendar.Time) + return Duration renames Ada.Calendar."-"; + TC_Start_Time : Ada.Calendar.Time := Ada.Calendar.Clock; + TC_Elapsed_Time : duration; + + -- Note: a properly executing test will complete immediately. + Allowable_ACK_Time : duration := 600.0; + +begin + + Report.Test ("C960004", "ATC: When abortable part completes before " & + "a triggering delay, check that the delay " & + "is cancelled & optional statements " & + "are not performed. Tasking situation"); + + declare -- To get the Report.Result after all has completed + + type Sequence_Number is range 1..1_999_999; -- Message Number + subtype S_length_subtype is integer range 1..80; + + type Message_Type (Max_String : S_length_subtype := 1) is + record + Message_Number : Sequence_Number; + Alpha : string(1..Max_String); + end record; + + -- TC: Dummy message for the test + Dummy_Alpha : constant string := "This could be printed"; + Message_to_Send : Message_Type (Max_string => Dummy_Alpha'length); + + + -- This is the carrier task. One of these is created for each + -- message that requires ACK + -- + task type Require_ACK_task is + entry Message_In (Message_to_Send: Message_Type); + end Require_ACK_task; + type acc_Require_ACK_task is access Require_ACK_task; + + + --::::::::::::::::::::::::::::::::: + -- There would also be another task type "No_ACK_Task" which would + -- be the carrier task for those messages not requiring an ACK. + -- This task would call Send_Message.ACK_Not_Required. It is not + -- shown in this test as it is not used. + --::::::::::::::::::::::::::::::::: + + + + task Send_Message is + entry ACK_Required (Message_to_Send: Message_Type); + entry ACK_Not_Required (Message_to_Send: Message_Type); + end Send_Message; + + + -- This is the carrier task. One of these is created for each + -- message that requires ACK + -- + task body Require_ACK_task is + Hold_Message : Message_Type; + + procedure Time_Out (Failed_Message_Number : Sequence_Number) is + begin + -- Take remedial action on the timed-out message + null; -- stub + + Report.Failed ("Optional statements in triggering part" & + " were performed"); + end Time_out; + + begin + accept Message_In (Message_to_Send: Message_Type) do + Hold_Message := Message_to_Send; -- to release caller + end Message_In; + + -- Now put the message out to the Send_Message task and + -- wait (no more than Allowable_Ack_Time) for its completion + -- + select + delay Allowable_ACK_Time; + -- ACK not received in specified time + Time_out (Hold_Message.Message_Number); + then abort + -- If the rendezvous is not completed in the above time, this + -- call is cancelled + -- Note: for this test this call will complete immediately + -- and thus the trigger should be cancelled + Send_Message.ACK_Required (Hold_Message); + end select; + + exception + when others => + Report.Failed ("Unexpected exception in Require_ACK_task"); + end Require_ACK_task; + + + -- This is the Line Driver task + -- + task body Send_Message is + Hold_Non_ACK_Message : Message_Type; + begin + loop + select + accept ACK_Required (Message_to_Send: Message_Type) do + -- Here send the message from within the rendezvous + -- waiting for full transmission to complete + null; -- stub + -- Note: In this test this accept will complete immediately + end ACK_Required; + or + accept ACK_Not_Required (Message_to_Send: Message_Type) do + Hold_Non_ACK_Message := Message_to_Send; + end ACK_Not_Required; + -- Here send the message from outside the rendezvous + null; -- stub + or + terminate; + end select; + end loop; + exception + when others => Report.Failed ("Unexpected exception in Send_Message"); + end Send_Message; + + begin -- declare + -- Build a dummy message + Message_to_Send.Alpha := Dummy_Alpha; + Message_to_Send.Message_Number := 110_693; + + declare + New_Require_ACK_task : acc_Require_ACK_task := + new Require_ACK_task; + begin + -- Create a carrier task for this message and pass the latter in + New_Require_ACK_task.Message_In (Message_to_Send); + end; -- declare + + end; -- declare + + --Once we are out of the above declarative region, all tasks have completed + + TC_Elapsed_Time := Ada.Calendar.Clock - TC_Start_Time; + + -- Check that the test has completed well before the time of the requested + -- delay to ensure the delay was cancelled + -- + if (TC_Elapsed_Time > Allowable_ACK_Time/2) then + Report.Failed ("Triggering delay statement was not cancelled"); + end if; + + Report.Result; +end C960004; diff --git a/gcc/testsuite/ada/acats/tests/c9/c96001a.ada b/gcc/testsuite/ada/acats/tests/c9/c96001a.ada new file mode 100644 index 000000000..f958ea107 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c96001a.ada @@ -0,0 +1,163 @@ +-- C96001A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT A DELAY STATEMENT DELAYS EXECUTION FOR AT LEAST THE +-- SPECIFIED TIME. SPECIFICALLY, +-- (A) POSITIVE DELAY ARGUMENT. +-- (B) NEGATIVE DELAY ARGUMENT. +-- (C) ZERO DELAY ARGUMENT. +-- (D) DURATION'SMALL DELAY ARGUMENT. +-- (E) EXPRESSION OF TYPE DURATION AS DELAY ARGUMENT. + +-- HISTORY: +-- CPP 8/14/84 CREATED ORIGINAL TEST. +-- RJW 11/13/87 ADDED CODE WHICH ALLOWS TEST TO REPORT "PASSED" +-- IF TICK > DURATION'SMALL. + +with Impdef; +WITH CALENDAR; USE CALENDAR; +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE C96001A IS + + SUBTYPE INT IS INTEGER RANGE 0 .. 20_000; + +BEGIN + TEST ("C96001A", "CHECK THAT DELAY STATEMENT DELAYS " & + "EXECUTION FOR AT LEAST THE SPECIFIED TIME"); + + --------------------------------------------- + + DECLARE -- (A) + X : DURATION := 5.0 * Impdef.One_Second; + OLD_TIME : TIME; + LAPSE : DURATION; + BEGIN -- (A) + LOOP + OLD_TIME := CLOCK; + DELAY X; + LAPSE := CLOCK - OLD_TIME; + EXIT; + END LOOP; + IF LAPSE < X THEN + FAILED ("DELAY DID NOT LAPSE AT LEAST 5.0 " & + "SECONDS - (A)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (A)"); + END; + + --------------------------------------------- + + DECLARE -- (B) + OLD_TIME : TIME; + LAPSE : DURATION; + BEGIN -- (B) + LOOP + OLD_TIME := CLOCK; + DELAY -5.0; + LAPSE := CLOCK - OLD_TIME; + EXIT; + END LOOP; + COMMENT ("(B) - NEGATIVE DELAY LAPSED FOR " & + INT'IMAGE (INT (LAPSE * 1_000)) & " MILLISECONDS"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (B)"); + END; + + --------------------------------------------- + + DECLARE -- (C) + X : DURATION := 0.0; + OLD_TIME : TIME; + LAPSE : DURATION; + BEGIN -- (C) + LOOP + OLD_TIME := CLOCK; + DELAY X; + LAPSE := CLOCK - OLD_TIME; + EXIT; + END LOOP; + COMMENT ("(C) - ZERO DELAY LAPSED FOR " & + INT'IMAGE (INT (LAPSE * 1_000)) & " MILLISECONDS"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (C)"); + END; + + --------------------------------------------- + + DECLARE -- (D) + X : DURATION := DURATION'SMALL; + OLD_TIME : TIME; + LAPSE : DURATION; + BEGIN -- (D) + LOOP + OLD_TIME := CLOCK; + DELAY X; + LAPSE := CLOCK - OLD_TIME; + EXIT; + END LOOP; + IF LAPSE < X THEN + IF TICK < DURATION'SMALL THEN + FAILED ("DELAY DID NOT LAPSE AT LEAST " & + "DURATION'SMALL SECONDS - (D)"); + ELSE + COMMENT ("TICK > DURATION'SMALL SO DELAY IN " & + "'(D)' IS NOT MEASURABLE"); + END IF; + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (D)"); + END; + + --------------------------------------------- + + DECLARE -- (E) + INC1 : DURATION := 2.0 * Impdef.One_Second; + INC2 : DURATION := 3.0 * Impdef.One_Second; + OLD_TIME : TIME; + LAPSE : DURATION; + BEGIN -- (E) + LOOP + OLD_TIME := CLOCK; + DELAY INC1 + INC2; + LAPSE := CLOCK - OLD_TIME; + EXIT; + END LOOP; + IF LAPSE < (INC1 + INC2) THEN + FAILED ("DELAY DID NOT LAPSE AT LEAST " & + "INC1 + INC2 SECONDS - (E)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (E)"); + END; + + RESULT; +END C96001A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c96004a.ada b/gcc/testsuite/ada/acats/tests/c9/c96004a.ada new file mode 100644 index 000000000..f5357fc51 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c96004a.ada @@ -0,0 +1,258 @@ +-- C96004A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE PRE-DEFINED SUBTYPES FROM THE PACKAGE CALENDAR, +-- NAMELY YEAR_NUMBER, MONTH_NUMBER, DAY_NUMBER, AND DAY_DURATION, +-- HAVE THE CORRECT RANGE CONSTRAINTS. SUBTESTS ARE: +-- (A) YEAR_NUMBER. +-- (B) MONTH_NUMBER. +-- (C) DAY_NUMBER. +-- (D) DAY_DURATION. + +-- HISTORY: +-- CPP 08/15/84 CREATED ORIGINAL TEST. +-- JET 01/06/88 UPDATED HEADER FORMAT AND ADDED CODE TO PREVENT +-- OPTIMIZATION. + +WITH CALENDAR; USE CALENDAR; +WITH REPORT; USE REPORT; +PROCEDURE C96004A IS + +BEGIN + TEST("C96004A", "CHECK THAT PRE-DEFINED SUBTYPES FROM THE " & + "CALENDAR PACKAGE HAVE CORRECT RANGE CONSTRAINTS"); + + --------------------------------------------- + + DECLARE -- (A) + + YR : YEAR_NUMBER; + + BEGIN -- (A) + + BEGIN + YR := 1900; + FAILED ("EXCEPTION NOT RAISED - (A)1"); + IF NOT EQUAL (YR, YR) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (A)1"); + END; + + BEGIN + YR := 84; + FAILED ("EXCEPTION NOT RAISED - (A)2"); + IF NOT EQUAL (YR, YR) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (A)2"); + END; + + BEGIN + YR := 2099; + IF NOT EQUAL (YR, YR) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("OK CASE RAISED EXCEPTION ON 2099 - (A)"); + END; + + BEGIN + YR := IDENT_INT(YEAR_NUMBER'LAST + 1); + FAILED ("EXCEPTION NOT RAISED - (A)3"); + IF NOT EQUAL (YR, YR) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (A)3"); + END; + + END; -- (A) + + --------------------------------------------- + + DECLARE -- (B) + + MO : MONTH_NUMBER; + + BEGIN -- (B) + + BEGIN + MO := IDENT_INT(0); + FAILED ("EXCEPTION NOT RAISED - (B)1"); + IF NOT EQUAL (MO, MO) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (B)1"); + END; + + BEGIN + MO := 12; + IF NOT EQUAL (MO, MO) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("OK CASE RAISED EXCEPTION ON 12 - (B)"); + END; + + BEGIN + MO := 13; + FAILED ("EXCEPTION NOT RAISED - (B)2"); + IF NOT EQUAL (MO, MO) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (B)2"); + END; + + END; -- (B) + + --------------------------------------------- + + DECLARE -- (C) + + DY : DAY_NUMBER; + + BEGIN -- (C) + + BEGIN + DY := 0; + FAILED ("EXCEPTION NOT RAISED - (C)1"); + IF NOT EQUAL (DY, DY) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (C)1"); + END; + + BEGIN + DY := IDENT_INT(32); + FAILED ("EXCEPTION NOT RAISED - (C)2"); + IF NOT EQUAL (DY, DY) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (C)2"); + END; + + END; -- (C) + + --------------------------------------------- + + DECLARE -- (D) + + SEGMENT : DAY_DURATION; + + FUNCTION CHECK_OK (X : DAY_DURATION) RETURN BOOLEAN IS + I : INTEGER := INTEGER (X); + BEGIN + RETURN EQUAL (I,I); + END CHECK_OK; + + BEGIN -- (D) + + BEGIN + SEGMENT := 86_400.0; + IF CHECK_OK (SEGMENT - 86_000.0) THEN + COMMENT ("NO EXCEPTION RAISED (D1)"); + ELSE + COMMENT ("NO EXCEPTION RAISED (D2)"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("OK CASE RAISED EXCEPTION ON 86_400 - (D)"); + END; + + BEGIN + SEGMENT := -4.0; + FAILED ("EXCEPTION NOT RAISED - (D)1"); + IF NOT EQUAL (INTEGER(SEGMENT), INTEGER(SEGMENT)) THEN + COMMENT ("NO EXCEPTION RAISED (D3)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (D)1"); + END; + + BEGIN + SEGMENT := 86_401.00; + IF CHECK_OK (SEGMENT - 86_000.0) THEN + FAILED ("NO EXCEPTION RAISED (D4)"); + ELSE + FAILED ("NO EXCEPTION RAISED (D5)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (D)2"); + END; + + END; -- (D) + + --------------------------------------------- + + RESULT; +END C96004A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c96005a.ada b/gcc/testsuite/ada/acats/tests/c9/c96005a.ada new file mode 100644 index 000000000..ca6fc5b83 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c96005a.ada @@ -0,0 +1,239 @@ +-- C96005A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THE CORRECTNESS OF THE ADDITION AND SUBTRACTION FUNCTIONS IN +-- THE PREDEFINED PACKAGE CALENDAR, AND APPROPRIATE EXCEPTION HANDLING. +-- SPECIFICALLY, +-- (A) CHECK THAT ADDITION AND SUBTRACTION OPERATORS WORK CORRECTLY ON +-- VALUES OF TYPE TIME. + +-- CPP 8/16/84 + +WITH CALENDAR; USE CALENDAR; +WITH REPORT; USE REPORT; +-- WITH TEXT_IO; USE TEXT_IO; +PROCEDURE C96005A IS + + -- PACKAGE DURATION_IO IS NEW FIXED_IO (DURATION); + -- USE DURATION_IO; + +BEGIN + TEST ("C96005A", "CHECK THAT THE ADDITION AND SUBTRACTION " & + "FUNCTIONS FOR VALUES OF TYPE TIME WORK CORRECTLY"); + + ----------------------------------------------- + + BEGIN -- (A) + + -- ADDITION TESTS FOLLOW. + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 13, 0.0); + NEW_TIME := NOW + INCREMENT; + IF NEW_TIME /= TIME_OF (1984, 8, 13, 1.0) THEN + FAILED ("SUM OF TIMES IS INCORRECT - (A)1"); + END IF; + END; + + + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 13, 0.0); + NEW_TIME := INCREMENT + NOW; + IF NEW_TIME /= TIME_OF (1984, 8, 13, 1.0) THEN + FAILED ("SUM OF TIMES IS INCORRECT - (A)2"); + END IF; + END; + + + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 13, 0.0); + NEW_TIME := "+"(INCREMENT, NOW); + IF NEW_TIME /= TIME_OF (1984, 8, 13, 1.0) THEN + FAILED ("SUM OF TIMES IS INCORRECT - (A)3"); + END IF; + END; + + + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 13, 0.0); + NEW_TIME := "+"(LEFT => NOW, + RIGHT => INCREMENT); + IF NEW_TIME /= TIME_OF (1984, 8, 13, 1.0) THEN + FAILED ("SUM OF TIMES IS INCORRECT - (A)4"); + END IF; + END; + + + -- SUBTRACTION TESTS FOLLOW. + DECLARE + NOW, ONCE : TIME; + DIFFERENCE : DURATION; + BEGIN + NOW := TIME_OF (1984, 8, 13, 45_000.0); + ONCE := TIME_OF (1984, 8, 12, 45_000.0); + DIFFERENCE := NOW - ONCE; + IF DIFFERENCE /= 86_400.0 THEN + FAILED ("DIFFERENCE OF TIMES IS INCORRECT - (A)1"); + -- COMMENT ("DIFFERENCE YIELDS: "); + -- PUT (DIFFERENCE); + END IF; + END; + + + DECLARE + -- TIMES IN DIFFERENT MONTHS. + NOW, ONCE : TIME; + DIFFERENCE : DURATION; + BEGIN + NOW := TIME_OF (1984, 8, IDENT_INT(1), 60.0); + ONCE := TIME_OF (1984, 7, 31, 86_399.0); + DIFFERENCE := "-"(NOW, ONCE); + IF DIFFERENCE /= 61.0 THEN + FAILED ("DIFFERENCE OF TIMES IS INCORRECT - (A)2"); + -- COMMENT ("DIFFERENCE YIELDS: "); + -- PUT (DIFFERENCE); + END IF; + END; + + + DECLARE + -- TIMES IN DIFFERENT YEARS. + NOW, AFTER : TIME; + DIFFERENCE : DURATION; + BEGIN + NOW := TIME_OF (IDENT_INT(1999), 12, 31, 86_399.0); + AFTER := TIME_OF (2000, 1, 1, 1.0); + DIFFERENCE := "-"(LEFT => AFTER, + RIGHT => NOW); + IF DIFFERENCE /= 2.0 THEN + FAILED ("DIFFERENCE OF TIMES IS INCORRECT - (A)3"); + -- COMMENT ("DIFFERENCE YIELDS: "); + -- PUT (DIFFERENCE); + END IF; + END; + + + DECLARE + -- TIMES IN A LEAP YEAR. + NOW, LEAP : TIME; + DIFFERENCE : DURATION; + BEGIN + NOW := TIME_OF (1984, 3, 1); + LEAP := TIME_OF (1984, 2, 29, 86_399.0); + DIFFERENCE := NOW - LEAP; + IF DIFFERENCE /= 1.0 THEN + FAILED ("DIFFERENCE OF TIMES IS INCORRECT - (A)4"); + -- COMMENT ("DIFFERENCE YIELDS: "); + -- PUT (DIFFERENCE); + END IF; + END; + + + DECLARE + -- TIMES IN A NON-LEAP YEAR. + NOW, NON_LEAP : TIME; + DIFFERENCE : DURATION; + BEGIN + NOW := TIME_OF (1983, 3, 1); + NON_LEAP := TIME_OF (1983, 2, 28, 86_399.0); + DIFFERENCE := NOW - NON_LEAP; + IF DIFFERENCE /= 1.0 THEN + FAILED ("DIFFERENCE OF TIMES IS INCORRECT - (A)5"); + -- COMMENT ("DIFFERENCE YIELDS: "); + -- PUT (DIFFERENCE); + END IF; + END; + + + -- SUBTRACTION TESTS FOLLOW: TIME - DURATION. + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 13, 0.0); + NEW_TIME := NOW - INCREMENT; + IF NEW_TIME /= TIME_OF (1984, 8, 12, 86_399.0) THEN + FAILED ("DIFFERENCE OF TIME AND DURATION IS " & + "INCORRECT - (A)6"); + END IF; + END; + + + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 1, 0.0); + NEW_TIME := NOW - INCREMENT; + IF NEW_TIME /= TIME_OF (1984, 7, 31, 86_399.0) THEN + FAILED ("DIFFERENCE OF TIME AND DURATION IS " & + "INCORRECT - (A)7"); + END IF; + END; + + + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 1, 0.0); + NEW_TIME := "-"(LEFT => NOW, + RIGHT => INCREMENT); + IF NEW_TIME /= TIME_OF (1984, 7, 31, 86_399.0) THEN + FAILED ("DIFFERENCE OF TIME AND DURATION IS " & + "INCORRECT - (A)8"); + END IF; + END; + + + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 1, 0.0); + NEW_TIME := "-"(NOW, INCREMENT); + IF NEW_TIME /= TIME_OF (1984, 7, 31, 86_399.0) THEN + FAILED ("DIFFERENCE OF TIME AND DURATION IS " & + "INCORRECT - (A)7"); + END IF; + END; + + + END; -- (A) + + ----------------------------------------------- + + RESULT; +END C96005A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c96005b.tst b/gcc/testsuite/ada/acats/tests/c9/c96005b.tst new file mode 100644 index 000000000..f4665b136 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c96005b.tst @@ -0,0 +1,135 @@ +-- C96005B.TST + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THE CORRECTNESS OF THE ADDITION AND SUBTRACTION FUNCTIONS IN +-- THE PREDEFINED PACKAGE CALENDAR, AND APPROPRIATE EXCEPTION HANDLING. +-- SPECIFICALLY, +-- (B) ADDITION AND SUBTRACTION OPERATORS RAISE CONSTRAINT_ERROR WHEN +-- CALLED WITH AN OUT OF RANGE DURATION PARAMETER. + +-- CPP 8/16/84 + +WITH CALENDAR; USE CALENDAR; +WITH REPORT; USE REPORT; +PROCEDURE C96005B IS + +BEGIN + TEST ("C96005B", "CHECK THAT ADDITION AND SUBTRACTION " & + "OPERATORS RAISE CONSTRAINT_ERROR WHEN CALLED WITH " & + "OUT OF RANGE DURATION PARAMETER"); + + ----------------------------------------------- + + BEGIN -- (B) + + -- ADDITION TESTS FOLLOW. + DECLARE + BEFORE : TIME := CLOCK; + BEGIN + IF DURATION'BASE'FIRST < DURATION'FIRST THEN + COMMENT("LOW VALUES EXIST - (B)1"); + BEFORE := BEFORE + ($LESS_THAN_DURATION); + FAILED ("EXCEPTION NOT RAISED - (B)1"); + ELSE + NOT_APPLICABLE ("NO LOW VALUES EXIST - (B)1"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN TIME_ERROR => + FAILED ("TIME_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - (B)1"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (B)1"); + END; + + DECLARE + BEFORE : TIME := CLOCK; + BEGIN + IF DURATION'LAST < DURATION'BASE'LAST THEN + COMMENT("HIGH VALUES EXIST - (B)2"); + BEFORE := $GREATER_THAN_DURATION + BEFORE; + FAILED ("EXCEPTION NOT RAISED - (B)2"); + ELSE + NOT_APPLICABLE ("NO HIGH VALUES EXIST - (B)2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN TIME_ERROR => + FAILED ("TIME_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - (B)2"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (B)2"); + END; + + + -- SUBTRACTION TESTS FOLLOW. + DECLARE + BEFORE : TIME := CLOCK; + BEGIN + IF DURATION'BASE'FIRST < DURATION'FIRST THEN + COMMENT("LOW VALUES EXIST - (B)3"); + BEFORE := BEFORE - ($LESS_THAN_DURATION); + FAILED ("EXCEPTION NOT RAISED - (B)3"); + ELSE + NOT_APPLICABLE ("NO LOW VALUES EXIST - (B)3"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN TIME_ERROR => + FAILED ("TIME_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - (B)3"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (B)3"); + END; + + DECLARE + BEFORE : TIME := CLOCK; + BEGIN + IF DURATION'LAST < DURATION'BASE'LAST THEN + COMMENT("HIGH VALUES EXIST - (B)4"); + BEFORE := BEFORE - $GREATER_THAN_DURATION; + FAILED ("EXCEPTION NOT RAISED - (B)4"); + ELSE + NOT_APPLICABLE ("NO HIGH VALUES EXIST - (B)4"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN TIME_ERROR => + FAILED ("TIME_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - (B)4"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (B)4"); + END; + + + END; -- (B) + + ----------------------------------------------- + + RESULT; +END C96005B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c96005d.ada b/gcc/testsuite/ada/acats/tests/c9/c96005d.ada new file mode 100644 index 000000000..8caba3e36 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c96005d.ada @@ -0,0 +1,81 @@ +-- C96005D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THE CORRECTNESS OF THE ADDITION AND SUBTRACTION FUNCTIONS IN +-- THE PREDEFINED PACKAGE CALENDAR, AND APPROPRIATE EXCEPTION HANDLING. +-- SPECIFICALLY, +-- (D) THE EXCEPTION TIME_ERROR IS RAISED WHEN THE FUNCTION "-" +-- RETURNS A VALUE NOT IN THE SUBTYPE RANGE DURATION. + +-- CPP 8/16/84 + +WITH CALENDAR; USE CALENDAR; +WITH REPORT; USE REPORT; +PROCEDURE C96005D IS + +BEGIN + TEST ("C96005D", "CHECK THAT THE SUBTRACTION OPERATOR RAISES " & + "TIME_ERROR APPROPRIATELY"); + + --------------------------------------------- + + BEGIN -- (D) + + DECLARE + NOW, LATER : TIME; + WAIT : DURATION; + BEGIN + NOW := TIME_OF (1984, 8, 13, 0.0); + LATER := (NOW + DURATION'LAST) + 1.0; + WAIT := LATER - NOW; + FAILED ("EXCEPTION NOT RAISED - (D)1"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (D)1"); + END; + + + DECLARE + NOW, LATER : TIME; + WAIT : DURATION; + BEGIN + NOW := TIME_OF (1984, 8, 13, 0.0); + LATER := (NOW + DURATION'FIRST) - 1.0; + WAIT := NOW - LATER; + FAILED ("EXCEPTION NOT RAISED - (D)2"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (D)2"); + END; + + END; -- (D) + + --------------------------------------------- + + RESULT; +END C96005D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c96005f.ada b/gcc/testsuite/ada/acats/tests/c9/c96005f.ada new file mode 100644 index 000000000..89e3d574b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c96005f.ada @@ -0,0 +1,93 @@ +-- C96005F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT PACKAGE CALENDAR + AND - FUNCTIONS WORK PROPERLY, +-- ESPECIALLY WITH VALUES AT MIDNIGHT. + +-- GOM 02/18/85 +-- JWC 05/14/85 + +WITH REPORT; +USE REPORT; +WITH CALENDAR; +USE CALENDAR; + +PROCEDURE C96005F IS + + CURR_DAY1 : CONSTANT TIME := TIME_OF(1984,1,1,0.0); + CURR_DAY2 : CONSTANT TIME := TIME_OF(1984,1,1,DAY_DURATION'LAST); + CURR_DAY3 : CONSTANT TIME := TIME_OF(1984,1,1,10000.0); + + TOMORROW1 : CONSTANT TIME := TIME_OF(1984,1,2,0.0); + TOMORROW2 : CONSTANT TIME := TIME_OF(1984,1,2,DAY_DURATION'LAST); + TOMORROW3 : CONSTANT TIME := TIME_OF(1984,1,2,10000.0); + + YESTERDAY1 : CONSTANT TIME := TIME_OF(1983,12,31,0.0); + YESTERDAY2 : CONSTANT TIME := TIME_OF(1983,12,31, + DAY_DURATION'LAST); + YESTERDAY3 : CONSTANT TIME := TIME_OF(1983,12,31,10000.0); + +BEGIN + TEST("C96005F","CHECKING PACKAGE CALENDAR + AND - FUNCTIONS"); + + -- CHECK IF ADDING ONE DAY TO 'CURR_DAY#' TIMES YIELDS + -- TIMES EQUAL TO 'TOMORROW'. + + IF (CURR_DAY1 + DAY_DURATION'LAST) /= TOMORROW1 THEN + FAILED("FAILURE IN ADDING 1 DAY TO 'CURR_DAY1'"); + END IF; + + IF (CURR_DAY2 + DAY_DURATION'LAST) /= TOMORROW2 THEN + FAILED("FAILURE IN ADDING 1 DAY TO 'CURR_DAY2'"); + END IF; + + IF (CURR_DAY3 + DAY_DURATION'LAST) /= TOMORROW3 THEN + FAILED("FAILURE IN ADDING 1 DAY TO 'CURR_DAY3'"); + END IF; + + IF (CURR_DAY1 + DAY_DURATION'LAST) /= CURR_DAY2 THEN + FAILED("'CURR_DAY1' + 1 /= 'CURR_DAY2'"); + END IF; + + -- CHECK IF SUBTRACTING ONE DAY FROM 'CURR_DAY#' TIMES YIELDS + -- TIMES EQUAL TO 'YESTERDAY'. + + IF (CURR_DAY1 - DAY_DURATION'LAST) /= YESTERDAY1 THEN + FAILED("FAILURE IN SUBTRACTING 1 DAY FROM 'CURR_DAY1'"); + END IF; + + IF (CURR_DAY2 - DAY_DURATION'LAST) /= YESTERDAY2 THEN + FAILED("FAILURE IN SUBTRACTING 1 DAY FROM 'CURR_DAY2'"); + END IF; + + IF (CURR_DAY3 - DAY_DURATION'LAST) /= YESTERDAY3 THEN + FAILED("FAILURE IN SUBTRACTING 1 DAY FROM 'CURR_DAY3'"); + END IF; + + IF (CURR_DAY2 - DAY_DURATION'LAST) /= CURR_DAY1 THEN + FAILED("'CURR_DAY2' - 1 /= 'CURR_DAY1'"); + END IF; + + RESULT; +END C96005F; diff --git a/gcc/testsuite/ada/acats/tests/c9/c96006a.ada b/gcc/testsuite/ada/acats/tests/c9/c96006a.ada new file mode 100644 index 000000000..0f6448bd2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c96006a.ada @@ -0,0 +1,298 @@ +-- C96006A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT FOR THE PACKAGE CALENDAR, THE RELATIONAL OPERATORS WORK +-- CORRECTLY FOR OPERANDS OF TYPE TIME AND TYPE DURATION. PARTICULARLY, +-- (A) RELATIONS BASED ON YEARS. +-- (B) RELATIONS BASED ON MONTH. +-- (C) RELATIONS BASED ON SECONDS. +-- (D) RELATIONS AT EXTREMES OF THE PERMITTED RANGE OF TIME. + +-- CPP 8/16/84 + +WITH CALENDAR; USE CALENDAR; +WITH REPORT; USE REPORT; +PROCEDURE C96006A IS + +BEGIN + TEST ("C96006A", "CHECK THAT RELATIONAL OPERATORS WORK " & + "CORRECTLY IN THE PACKAGE CALENDAR"); + + -------------------------------------------- + + DECLARE -- (A) + -- RELATIONS BASED ON YEARS. + NOW, LATER : TIME; + BEGIN -- (A) + NOW := TIME_OF (1984, 8, 12, 500.0); + LATER := TIME_OF (1985, 8, 12, 500.0); + + IF NOW < LATER THEN + COMMENT ("< OPERATOR OK - (A)"); + ELSE + FAILED ("< OPERATOR INCORRECT - (A)"); + END IF; + + IF NOW <= LATER THEN + COMMENT ("<= OPERATOR OK - (A)"); + ELSE + FAILED ("<= OPERATOR INCORRECT - (A)"); + END IF; + + IF NOW <= NOW THEN + COMMENT ("<= OPERATOR OK - (A)2"); + ELSE + FAILED ("<= OPERATOR INCORRECT - (A)2"); + END IF; + + IF LATER > NOW THEN + COMMENT ("> OPERATOR OK - (A)"); + ELSE + FAILED ("> OPERATOR INCORRECT - (A)"); + END IF; + + IF LATER >= NOW THEN + COMMENT (">= OPERATOR OK - (A)"); + ELSE + FAILED (">= OPERATOR INCORRECT - (A)"); + END IF; + + IF LATER >= LATER THEN + COMMENT (">= OPERATOR OK - (A)2"); + ELSE + FAILED (">= OPERATOR INCORRECT - (A)2"); + END IF; + + END; -- (A) + + -------------------------------------------- + + DECLARE -- (B) + -- RELATIONS BASED ON MONTH. + NOW, LATER : TIME; + BEGIN -- (B) + NOW := TIME_OF (1984, 8, 12, 500.0); + LATER := TIME_OF (1984, 9, 12, 500.0); + + IF NOW < LATER THEN + COMMENT ("< OPERATOR OK - (B)"); + ELSE + FAILED ("< OPERATOR INCORRECT - (B)"); + END IF; + + IF NOW <= LATER THEN + COMMENT ("<= OPERATOR OK - (B)"); + ELSE + FAILED ("<= OPERATOR INCORRECT - (B)"); + END IF; + + IF NOW <= NOW THEN + COMMENT ("<= OPERATOR OK - (B)2"); + ELSE + FAILED ("<= OPERATOR INCORRECT - (B)2"); + END IF; + + IF LATER > NOW THEN + COMMENT ("> OPERATOR OK - (B)"); + ELSE + FAILED ("> OPERATOR INCORRECT - (B)"); + END IF; + + IF LATER >= NOW THEN + COMMENT (">= OPERATOR OK - (B)"); + ELSE + FAILED (">= OPERATOR INCORRECT - (B)"); + END IF; + + IF LATER >= LATER THEN + COMMENT (">= OPERATOR OK - (B)2"); + ELSE + FAILED (">= OPERATOR INCORRECT - (B)2"); + END IF; + + IF NOW = NOW THEN + COMMENT ("= OPERATOR OK - (B)"); + ELSE + FAILED ("= OPERATOR INCORRECT - (B)"); + END IF; + + IF LATER /= NOW THEN + COMMENT ("/= OPERATOR OK - (B)"); + ELSE + FAILED ("/= OPERATOR INCORRECT - (B)"); + END IF; + + END; -- (B) + + -------------------------------------------- + + DECLARE -- (C) + -- RELATIONS BASED ON SECONDS. + NOW, LATER : TIME; + INCREMENT : DURATION := 99.9; + BEGIN -- (C) + NOW := TIME_OF (1984, 8, 12, 500.0); + LATER := NOW + INCREMENT; + + IF NOW < LATER THEN + COMMENT ("< OPERATOR OK - (C)"); + ELSE + FAILED ("< OPERATOR INCORRECT - (C)"); + END IF; + + IF NOW <= LATER THEN + COMMENT ("<= OPERATOR OK - (C)"); + ELSE + FAILED ("<= OPERATOR INCORRECT - (C)"); + END IF; + + IF NOW <= NOW THEN + COMMENT ("<= OPERATOR OK - (C)2"); + ELSE + FAILED ("<= OPERATOR INCORRECT - (C)2"); + END IF; + + IF LATER > NOW THEN + COMMENT ("> OPERATOR OK - (C)"); + ELSE + FAILED ("> OPERATOR INCORRECT - (C)"); + END IF; + + IF LATER >= NOW THEN + COMMENT (">= OPERATOR OK - (C)"); + ELSE + FAILED (">= OPERATOR INCORRECT - (C)"); + END IF; + + IF LATER >= LATER THEN + COMMENT (">= OPERATOR OK - (C)2"); + ELSE + FAILED (">= OPERATOR INCORRECT - (C)2"); + END IF; + + IF LATER = LATER THEN + COMMENT ("= OPERATOR OK - (C)"); + ELSE + FAILED ("= OPERATOR INCORRECT - (C)"); + END IF; + + IF NOW /= LATER THEN + COMMENT ("/= OPERATOR OK - (C)"); + ELSE + FAILED ("/= OPERATOR INCORRECT - (C)"); + END IF; + + IF NOW < NOW THEN + FAILED ("NOW < NOW INCORRECT - (C)"); + ELSIF NOW /= NOW THEN + FAILED ("NOW = NOW INCORRECT - (C)"); + ELSIF LATER < NOW THEN + FAILED ("LATER < NOW INCORRECT - (C)"); + ELSIF LATER <= NOW THEN + FAILED ("LATER <= NOW INCORRECT - (C)"); + ELSIF LATER = NOW THEN + FAILED ("NOW = LATER INCORRECT - (C)"); + ELSIF NOW > LATER THEN + FAILED ("NOW > LATER INCORRECT - (C)"); + ELSIF NOW > NOW THEN + FAILED ("NOW > NOW INCORRECT - (C)"); + ELSIF NOW >= LATER THEN + FAILED ("NOW >= LATER INCORRECT - (C)"); + ELSIF NOW = LATER THEN + FAILED ("NOW = LATER INCORRECT - (C)"); + END IF; + + END; -- (C) + + -------------------------------------------- + + DECLARE -- (D) + + NOW, WAY_BACK_THEN : TIME; + + BEGIN -- (D) + + NOW := TIME_OF (2099, 12, 31); + WAY_BACK_THEN := TIME_OF (1901, 1, 1); + + BEGIN + IF NOW < WAY_BACK_THEN THEN + FAILED ("TEST < AT EXTREMES INCORRECT - (D)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("< AT EXTREMES RAISED EXCEPTION - (D)"); + END; + + BEGIN + IF NOW <= WAY_BACK_THEN THEN + FAILED ("TEST <= AT EXTREMES INCORRECT - (D)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("<= AT EXTREMES RAISED EXCEPTION - (D)"); + END; + + BEGIN + IF WAY_BACK_THEN > NOW THEN + FAILED ("TEST > AT EXTREMES INCORRECT - (D)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("> AT EXTREMES RAISED EXCEPTION - (D)"); + END; + + BEGIN + IF WAY_BACK_THEN >= NOW THEN + FAILED ("TEST >= AT EXTREMES INCORRECT - (D)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED (">= AT EXTREMES RAISED EXCEPTION - (D)"); + END; + + BEGIN + IF WAY_BACK_THEN /= WAY_BACK_THEN THEN + FAILED ("TEST /= AT EXTREMES INCORRECT - (D)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("/= AT EXTREMES RAISED EXCEPTION - (D)"); + END; + + BEGIN + IF NOW = WAY_BACK_THEN THEN + FAILED ("TEST = AT EXTREMES INCORRECT - (D)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("= AT EXTREMES RAISED EXCEPTION - (D)"); + END; + + END; -- (D) + + -------------------------------------------- + + RESULT; +END C96006A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c96007a.ada b/gcc/testsuite/ada/acats/tests/c9/c96007a.ada new file mode 100644 index 000000000..beda25fd5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c96007a.ada @@ -0,0 +1,203 @@ +-- C96007A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT APPROPRIATE EXCEPTIONS ARE RAISED FOR THE TIME_OF() +-- FUNCTION IN THE PACKAGE CALENDAR. PARTICULARLY, +-- (A) TIME_ERROR IS RAISED ON INVALID DATES. +-- (B) CONSTRAINT_ERROR IS RAISED FOR OUT-OF-RANGE PARAMETERS. + +-- CPP 8/16/84 + +WITH CALENDAR; USE CALENDAR; +WITH REPORT; USE REPORT; +PROCEDURE C96007A IS + +BEGIN + TEST ("C96007A", "CHECK THAT APPROPRIATE EXCEPTIONS ARE RAISED " & + "FOR THE TIME_OF FUNCTION IN THE PACKAGE CALENDAR"); + + -------------------------------------------- + + DECLARE -- (A) + + BAD_TIME : TIME; + + BEGIN -- (A) + + BEGIN + BAD_TIME := TIME_OF (1984, 2, 30); + FAILED ("EXCEPTION NOT RAISED - 2/30 (A)"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2/30 (A)"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 2, 31); + FAILED ("EXCEPTION NOT RAISED - 2/31 (A)"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2/31 (A)"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 4, 31); + FAILED ("EXCEPTION NOT RAISED - 4/31 (A)"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 4/31 (A)"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 6, 31); + FAILED ("EXCEPTION NOT RAISED - 6/31 (A)"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 6/31 (A)"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 9, 31); + FAILED ("EXCEPTION NOT RAISED - 9/31 (A)"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 9/31 (A)"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 11, 31); + FAILED ("EXCEPTION NOT RAISED - 11/31 (A)"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 11/31 (A)"); + END; + + BEGIN + BAD_TIME := TIME_OF (1983, 2, 29); + FAILED ("EXCEPTION NOT RAISED - 2/29 (A)"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2/29 (A)"); + END; + + END; -- (A) + + -------------------------------------------- + + DECLARE -- (B) + + BAD_TIME : TIME; + + BEGIN -- (B) + + BEGIN + BAD_TIME := TIME_OF (1900, 8, 13); + FAILED ("EXCEPTION NOT RAISED - 1900 (B)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 1900 (B)"); + END; + + BEGIN + BAD_TIME := TIME_OF (YEAR_NUMBER'LAST + 1, 8, 13); + FAILED ("EXCEPTION NOT RAISED - 2100 (B)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2100 (B)"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 0, 13); + FAILED ("EXCEPTION NOT RAISED - MONTH (B)1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - MONTH (B)1"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 13, 13); + FAILED ("EXCEPTION NOT RAISED - MONTH (B)2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - MONTH (B)2"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 8, 0); + FAILED ("EXCEPTION NOT RAISED - DAY (B)1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - DAY (B)1"); + END; + + BEGIN + BAD_TIME := TIME_OF (19784, 8, 32); + FAILED ("EXCEPTION NOT RAISED - DAY (B)2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - DAY (B)2"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 8, 13, -0.5); + FAILED ("EXCEPTION NOT RAISED - SECONDS (B)1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - SECONDS (B)1"); + END; + + END; -- (B) + + -------------------------------------------- + + RESULT; +END C96007A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c96008a.ada b/gcc/testsuite/ada/acats/tests/c9/c96008a.ada new file mode 100644 index 000000000..33b59d8c1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c96008a.ada @@ -0,0 +1,203 @@ +-- C96008A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- MISCELLANEOUS CHECKS ON THE PRE-DEFINED FUNCTIONS IN THE PACKAGE +-- CALENDAR. SUBTESTS ARE: +-- (A) TIME_OF() AND SPLIT() ARE INVERSE FUNCTIONS. +-- (B) FORMAL PARAMETERS OF TIME_OF() AND SPLIT() ARE NAMED CORRECTLY. +-- (C) TIME_OF() GIVES THE PARAMETER SECONDS A DEFAULT VALUE OF 0.0. +-- (D) THE FUNCTIONS YEAR(), MONTH(), DAY(), AND SECONDS() RETURN +-- CORRECT VALUES USING NAMED NOTATION. +-- (E) A VALUE RETURNED FROM CLOCK() CAN BE PROCESSED BY SPLIT(). +-- (F) DURATION'SMALL MEETS REQUIRED LIMIT. + +-- CPP 8/16/84 + +WITH SYSTEM; +WITH CALENDAR; USE CALENDAR; +WITH REPORT; USE REPORT; +PROCEDURE C96008A IS + +BEGIN + TEST ("C96008A", "CHECK MISCELLANEOUS FUNCTIONS IN THE " & + "PACKAGE CALENDAR"); + + --------------------------------------------- + + DECLARE -- (A) + NOW : TIME; + YR : YEAR_NUMBER; + MO : MONTH_NUMBER; + DY : DAY_NUMBER; + SEC : DAY_DURATION; + BEGIN -- (A) + BEGIN + NOW := TIME_OF (1984, 8, 13, DURATION(1.0/3.0)); + SPLIT (NOW, YR, MO, DY, SEC); + IF NOW /= TIME_OF (YR, MO, DY, SEC) THEN + COMMENT ("TIME_OF AND SPLIT ARE NOT INVERSES " & + "WHEN SECONDS IS A NON-MODEL NUMBER " & + "- (A)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("TIME_OF(SPLIT) RAISED EXCEPTION - (A)"); + END; + + + BEGIN + -- RESET VALUES. + YR := 1984; + MO := 8; + DY := 13; + SEC := 1.0; + + SPLIT (TIME_OF (YR, MO, DY, SEC), YR, MO, DY, SEC); + + IF YR /= 1984 THEN + FAILED ("SPLIT(TIME_OF) CHANGED VALUE OF YR - (A)"); + END IF; + + IF MO /= 8 THEN + FAILED ("SPLIT(TIME_OF) CHANGED VALUE OF MO - (A)"); + END IF; + + IF DY /= 13 THEN + FAILED ("SPLIT(TIME_OF) CHANGED VALUE OF DY - (A)"); + END IF; + + IF SEC /= 1.0 THEN + FAILED ("SPLIT(TIME_OF) CHANGED VALUE OF " & + "SEC - (A)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("SPLIT(TIME_OF) PROCESSING RAISED " & + "EXCEPTION - (A)"); + END; + END; -- (A) + + --------------------------------------------- + + BEGIN -- (B) + DECLARE + NOW : TIME; + BEGIN + NOW := TIME_OF (YEAR => 1984, + MONTH => 8, + DAY => 13, + SECONDS => 60.0); + EXCEPTION + WHEN OTHERS => + FAILED ("NAMED ASSOCIATION ON TIME_OF() RAISED " & + "EXCEPTION - (B)"); + END; + + + DECLARE + NOW : TIME := CLOCK; + YR : YEAR_NUMBER := 1984; + MO : MONTH_NUMBER := 8; + DY : DAY_NUMBER := 13; + SEC : DAY_DURATION := 0.0; + BEGIN + SPLIT (DATE => NOW, + YEAR => YR, + MONTH => MO, + DAY => DY, + SECONDS => SEC); + EXCEPTION + WHEN OTHERS => + FAILED ("NAMED ASSOCIATION ON SPLIT() RAISED " & + "EXCEPTION - (B)2"); + END; + END; -- (B) + + --------------------------------------------- + + DECLARE -- (C) + NOW : TIME; + BEGIN -- (C) + NOW := TIME_OF (1984, 8, 13); + IF SECONDS (NOW) /= 0.0 THEN + FAILED ("TIME_OF() DID NOT ZERO SECONDS - (C)"); + END IF; + END; -- (C) + + --------------------------------------------- + + DECLARE -- (D) + -- ASSUMES TIME_OF() WORKS CORRECTLY. + HOLIDAY : TIME; + BEGIN -- (D) + HOLIDAY := TIME_OF (1958, 9, 9, 1.0); + + IF YEAR (DATE => HOLIDAY) /= 1958 THEN + FAILED ("YEAR() DID NOT RETURN CORRECT VALUE - (D)"); + END IF; + + IF MONTH (DATE => HOLIDAY) /= 9 THEN + FAILED ("MONTH() DID NOT RETURN CORRECT VALUE - (D)"); + END IF; + + IF DAY (DATE => HOLIDAY) /= 9 THEN + FAILED ("DAY() DID NOT RETURN CORRECT VALUE - (D)"); + END IF; + + IF SECONDS (HOLIDAY) /= 1.0 THEN + FAILED ("SECONDS() DID NOT RETURN CORRECT VALUE - (D)"); + END IF; + END; -- (D) + + --------------------------------------------- + + DECLARE -- (E) + YR : YEAR_NUMBER; + MO : MONTH_NUMBER; + DY : DAY_NUMBER; + SEC : DAY_DURATION; + BEGIN -- (E) + SPLIT (CLOCK, YR, MO, DY, SEC); + DELAY SYSTEM.TICK; + + IF TIME_OF (YR, MO, DY, SEC) > CLOCK THEN + FAILED ("SPLIT() ON CLOCK INCORRECT - (E)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("SPLIT() ON CLOCK RAISED EXCEPTION - (E)"); + END; -- (E) + + --------------------------------------------- + + BEGIN -- (F) + IF DURATION'SMALL > 0.020 THEN + FAILED ("DURATION'SMALL LARGER THAN SPECIFIED - (F)"); + END IF; + END; -- (F) + + --------------------------------------------- + + RESULT; +END C96008A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c96008b.ada b/gcc/testsuite/ada/acats/tests/c9/c96008b.ada new file mode 100644 index 000000000..7a23bcfb4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c96008b.ada @@ -0,0 +1,71 @@ +-- C96008B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- MISCELLANEOUS CHECKS ON THE PRE-DEFINED FUNCTIONS IN THE PACKAGE +-- CALENDAR. SUBTESTS ARE: +-- (A) THE FUNCTION TIME_OF() MUST ADVANCE DAY WHEN CALLED WITH THE +-- SECONDS ARGUMENT HAVING THE VALUE 86_400. + +-- CPP 8/16/84 +-- JRK 12/4/84 + +WITH CALENDAR; USE CALENDAR; +WITH REPORT; USE REPORT; +PROCEDURE C96008B IS + + NOW1, NOW2 : TIME; + YR : YEAR_NUMBER; + MO : MONTH_NUMBER; + DY : DAY_NUMBER; + SEC : DAY_DURATION; + +BEGIN + + TEST ("C96008B", "CHECK THAT TIME_OF() ADVANCES DAY"); + + NOW1 := TIME_OF (1984, 8, 13, 86_400.0); + NOW2 := TIME_OF (1984, 8, 14, 0.0); + + IF NOW1 /= NOW2 THEN + FAILED ("TIME_OF DID NOT CONVERT 86_400 SECONDS TO A DAY"); + END IF; + + SPLIT (NOW2, YR, MO, DY, SEC); + + IF DY /= 14 THEN + FAILED ("DAY OF NOW2 INCORRECT"); + END IF; + IF SEC /= 0.0 THEN + FAILED ("SECONDS OF NOW2 INCORRECT"); + END IF; + + SPLIT (NOW1, YR, MO, DY, SEC); + + IF DY /= 14 OR SEC /= 0.0 OR + DAY (NOW1) /= 14 OR SECONDS (NOW1) /= 0.0 THEN + FAILED ("TIME_OF DID NOT ADVANCE DAY"); + END IF; + + RESULT; +END C96008B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97112a.ada b/gcc/testsuite/ada/acats/tests/c9/c97112a.ada new file mode 100644 index 000000000..ef7dca2d4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97112a.ada @@ -0,0 +1,134 @@ +-- C97112A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A DELAY STATEMENT IS ALLOWED IN THE SEQUENCE OF STATEMENTS +-- OF A SELECT ALTERNATIVE OF A SELECTIVE WAIT CONTAINING A TERMINATE +-- ALTERNATIVE OR AN ELSE PART. + +-- WRG 7/9/86 + +with Impdef; +WITH REPORT; USE REPORT; +WITH CALENDAR; USE CALENDAR; +PROCEDURE C97112A IS + + ACCEPT_ALTERNATIVE_TAKEN : BOOLEAN := FALSE; + +BEGIN + + TEST ("C97112A", "CHECK THAT A DELAY STATEMENT IS ALLOWED IN " & + "THE SEQUENCE OF STATEMENTS OF A SELECT " & + "ALTERNATIVE OF A SELECTIVE WAIT CONTAINING A " & + "TERMINATE ALTERNATIVE OR AN ELSE PART"); + + -------------------------------------------------- + + A: DECLARE + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + BEFORE, AFTER : TIME; + BEGIN + SELECT + ACCEPT E; + ACCEPT_ALTERNATIVE_TAKEN := TRUE; + BEFORE := CLOCK; + DELAY 10.0 * Impdef.One_Second; + AFTER := CLOCK; + IF AFTER - BEFORE < 10.0 * Impdef.One_Second THEN + FAILED ("INSUFFICIENT DELAY (A)"); + END IF; + OR + TERMINATE; + END SELECT; + END T; + + BEGIN + + T.E; + + END A; + + IF NOT ACCEPT_ALTERNATIVE_TAKEN THEN + FAILED ("ACCEPT ALTERNATIVE NOT TAKEN"); + END IF; + + -------------------------------------------------- + + B: DECLARE + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + BEFORE, AFTER : TIME; + BEGIN + --ENSURE THAT E HAS BEEN CALLED BEFORE PROCEEDING: + WHILE E'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + SELECT + ACCEPT E; + BEFORE := CLOCK; + DELAY 10.0 * Impdef.One_Second; + AFTER := CLOCK; + IF AFTER - BEFORE < 10.0 * Impdef.One_Second THEN + FAILED ("INSUFFICIENT DELAY (B-1)"); + END IF; + ELSE + FAILED ("ELSE PART EXECUTED (B-1)"); + END SELECT; + + SELECT + ACCEPT E; + FAILED ("ACCEPT STATEMENT EXECUTED (B-2)"); + ELSE + BEFORE := CLOCK; + DELAY 10.0 * Impdef.One_Second; + AFTER := CLOCK; + IF AFTER - BEFORE < 10.0 * Impdef.One_Second THEN + FAILED ("INSUFFICIENT DELAY (B-2)"); + END IF; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END T; + + BEGIN + + T.E; + + END B; + + -------------------------------------------------- + + RESULT; + +END C97112A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97113a.ada b/gcc/testsuite/ada/acats/tests/c9/c97113a.ada new file mode 100644 index 000000000..f05d4380c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97113a.ada @@ -0,0 +1,113 @@ +-- C97113A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT ALL CONDITIONS, OPEN DELAY ALTERNATIVE EXPRESSIONS, AND +-- OPEN ENTRY FAMILY INDICES ARE EVALUATED (EVEN WHEN SOME (PERHAPS +-- ALL BUT ONE) OF THE ALTERNATIVES CAN BE RULED OUT WITHOUT +-- COMPLETING THE EVALUATIONS). + +-- RM 5/06/82 +-- SPS 11/21/82 +-- WRG 7/9/86 ADDED DELAY EXPRESSIONS AND ENTRY FAMILY INDICES. + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C97113A IS + + EXPR1_EVALUATED : BOOLEAN := FALSE; + EXPR2_EVALUATED : BOOLEAN := FALSE; + EXPR3_EVALUATED : BOOLEAN := FALSE; + + FUNCTION F1 RETURN BOOLEAN IS + BEGIN + EXPR1_EVALUATED := TRUE; + RETURN TRUE; + END F1; + + FUNCTION F2 (X : INTEGER) RETURN INTEGER IS + BEGIN + EXPR2_EVALUATED := TRUE; + RETURN X; + END F2; + + FUNCTION F3 (X : DURATION) RETURN DURATION IS + BEGIN + EXPR3_EVALUATED := TRUE; + RETURN X; + END F3; + +BEGIN + + TEST ("C97113A", "CHECK THAT ALL CONDITIONS, OPEN DELAY " & + "ALTERNATIVE EXPRESSIONS, AND OPEN ENTRY " & + "FAMILY INDICES ARE EVALUATED"); + + DECLARE + + TASK T IS + ENTRY E1; + ENTRY E2; + ENTRY E3 (1..1); + END T; + + TASK BODY T IS + BEGIN + --ENSURE THAT E1 HAS BEEN CALLED BEFORE PROCEEDING: + WHILE E1'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + SELECT + ACCEPT E1; + OR + WHEN F1 => + ACCEPT E2; + OR + ACCEPT E3 ( F2(1) ); + OR + DELAY F3 ( 1.0 ) * Impdef.One_Second; + END SELECT; + END T; + + BEGIN + + T.E1; + + END; + + IF NOT EXPR1_EVALUATED THEN + FAILED ("GUARD NOT EVALUATED"); + END IF; + + IF NOT EXPR2_EVALUATED THEN + FAILED ("ENTRY FAMILY INDEX NOT EVALUATED"); + END IF; + + IF NOT EXPR3_EVALUATED THEN + FAILED ("OPEN DELAY ALTERNATIVE EXPRESSION NOT EVALUATED"); + END IF; + + RESULT; + +END C97113A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97114a.ada b/gcc/testsuite/ada/acats/tests/c9/c97114a.ada new file mode 100644 index 000000000..2a28fe8e8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97114a.ada @@ -0,0 +1,196 @@ +-- C97114A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK WHETHER A DELAY EXPRESSION FOLLOWING AN OPEN GUARD IS EVALUATED +-- DIRECTLY AFTER THE GUARD OR ONLY AFTER ALL GUARDS HAVE BEEN +-- EVALUATED, OR IN SOME MIXED ORDER SUCH THAT DELAY EXPRESSIONS ARE +-- EVALUATED AFTER THEIR GUARDS ARE DETERMINED TO BE OPEN. + +-- RM 5/10/82 +-- SPS 11/21/82 +-- JBG 10/24/83 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C97114A IS + + + -- THE TASK WILL HAVE LAST PRIORITY ( PRIORITY'FIRST ) + + EVAL_ORDER : STRING (1..6) := ( 1..6 => '*' ); + EVAL_ORD : STRING (1..6) := ( 1..6 => '*' ); + INDEX : INTEGER := 0; + DUMMY : INTEGER := 0; + + + FUNCTION F1 (X:INTEGER) RETURN INTEGER IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'F'; -- 123: FGH + EVAL_ORD (INDEX) := 'G'; -- 123: GGG ( 'G' FOR 'GUARD' ) + RETURN ( IDENT_INT(7) ); + END F1; + + + FUNCTION F2 (X:INTEGER) RETURN INTEGER IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'G'; + EVAL_ORD (INDEX) := 'G'; + RETURN ( IDENT_INT(7) ); + END F2; + + + FUNCTION F3 (X:INTEGER) RETURN INTEGER IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'H'; + EVAL_ORD (INDEX) := 'G'; + RETURN ( IDENT_INT(7) ); + END F3; + + + FUNCTION D1( X:INTEGER ) RETURN DURATION IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'A'; -- 123: ABC + EVAL_ORD (INDEX) := 'D'; -- 123: DDD ( 'D' FOR 'DELAY' ) + RETURN ( 1.0 ); + END D1; + + + FUNCTION D2( X:INTEGER ) RETURN DURATION IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'B'; + EVAL_ORD (INDEX) := 'D'; + RETURN ( 2.0 ); + END D2; + + + FUNCTION D3( X:INTEGER ) RETURN DURATION IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'C'; + EVAL_ORD (INDEX) := 'D'; + RETURN ( 3.0 ); + END D3; + + FUNCTION POS_OF (FUNC : CHARACTER) RETURN INTEGER IS + BEGIN + FOR I IN EVAL_ORDER'RANGE LOOP + IF EVAL_ORDER(I) = FUNC THEN + RETURN I; + END IF; + END LOOP; + FAILED ("DID NOT FIND LETTER " & FUNC); + RETURN 0; + END POS_OF; + +BEGIN + + + TEST ("C97114A", "CHECK THAT THE DELAY EXPRESSIONS ARE" & + " EVALUATED AFTER THE GUARDS BUT" & + " BEFORE THE RENDEZVOUS IS ATTEMPTED" ); + + + DECLARE + + + TASK T IS + + + ENTRY E1; + + END T; + + + TASK BODY T IS + BEGIN + + + WHILE E1'COUNT = 0 -- IF E1 NOT YET CALLED, THEN GIVE + LOOP -- THE MAIN TASK AN OPPORTUNITY + DELAY 10.01 * Impdef.One_Second; -- TO ISSUE THE CALL. + END LOOP; + + + SELECT + + ACCEPT E1; + + OR + + WHEN 6 + F1(7) = 13 => + DELAY D1( DUMMY ) * Impdef.One_Second; + + OR + + WHEN 6 + F2(7) = 13 => + DELAY D2( DUMMY ) * Impdef.One_Second; + + OR + + WHEN 6 + F3(7) = 13 => + DELAY D3( DUMMY ) * Impdef.One_Second; + + END SELECT; + + + END T; + + + BEGIN + + T.E1; + + END; -- END OF BLOCK CONTAINING THE ENTRY CALLS + + + COMMENT ("EVALUATIONS WERE DONE IN THE ORDER " & EVAL_ORD); + COMMENT ("FUNCTIONS WERE CALLED IN THE ORDER " & EVAL_ORDER); + + IF EVAL_ORD = "GGGDDD" THEN + COMMENT ("ALL GUARDS EVALUATED FIRST"); + ELSIF EVAL_ORD = "GDGDGD" THEN + COMMENT ("DELAY EXPRESSION EVALUATED AFTER EACH GUARD"); + END IF; + +-- CHECK THAT GUARDS ARE ALWAYS EVALUATED BEFORE DELAY EXPRESSIONS + + IF POS_OF ('F') > POS_OF ('A') OR + POS_OF ('G') > POS_OF ('B') OR + POS_OF ('H') > POS_OF ('C') THEN + FAILED ("A DELAY EXPRESSION WAS EVALUATED BEFORE ITS " & + "GUARD"); + END IF; + + + RESULT; + + +END C97114A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97115a.ada b/gcc/testsuite/ada/acats/tests/c9/c97115a.ada new file mode 100644 index 000000000..8e9845ea6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97115a.ada @@ -0,0 +1,189 @@ +-- C97115A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK WHETHER AN ENTRY FAMILY INDEX EXPRESSION FOLLOWING AN OPEN +-- GUARD IS EVALUATED DIRECTLY AFTER THE GUARD, OR ONLY AFTER ALL GUARDS +-- HAVE BEEN EVALUATED, OR IN SOME MIXED ORDER SUCH THAT INDEX +-- EXPRESSIONS ARE EVALUATED AFTER THEIR GUARDS ARE DETERMINED TO BE +-- OPEN. + +-- RM 5/11/82 +-- SPS 11/21/82 +-- JBG 10/24/83 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C97115A IS + + + -- THE TASK WILL HAVE LAST PRIORITY ( PRIORITY'FIRST ) + + EVAL_ORDER : STRING (1..6) := ( 1..6 => '*' ); + EVAL_ORD : STRING (1..6) := ( 1..6 => '*' ); + INDEX : INTEGER := 0; + + + FUNCTION F1 (X:INTEGER) RETURN INTEGER IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'F'; -- 123: FGH + EVAL_ORD (INDEX) := 'G'; -- 123: GGG ( 'G' FOR 'GUARD' ) + RETURN ( IDENT_INT(7) ); + END F1; + + + FUNCTION F2 (X:INTEGER) RETURN INTEGER IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'G'; + EVAL_ORD (INDEX) := 'G'; + RETURN ( IDENT_INT(7) ); + END F2; + + + FUNCTION F3 (X:INTEGER) RETURN INTEGER IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'H'; + EVAL_ORD (INDEX) := 'G'; + RETURN ( IDENT_INT(7) ); + END F3; + + + FUNCTION I1 ( X:INTEGER ) RETURN BOOLEAN IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'A'; -- 123: ABC + EVAL_ORD (INDEX) := 'I'; -- 123: III ( 'I' FOR 'INDEX' ) + RETURN ( IDENT_BOOL(TRUE) ); -- (THAT'S ENTRY-FAMILY INDEX) + END I1; + + + FUNCTION I2 ( X:INTEGER ) RETURN BOOLEAN IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'B'; + EVAL_ORD (INDEX) := 'I'; + RETURN ( IDENT_BOOL(TRUE) ); + END I2; + + + FUNCTION I3 ( X:INTEGER ) RETURN BOOLEAN IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'C'; + EVAL_ORD (INDEX) := 'I'; + RETURN ( IDENT_BOOL(TRUE) ); + END I3; + + FUNCTION POS_OF (FUNC : CHARACTER) RETURN INTEGER IS + BEGIN + FOR I IN EVAL_ORDER'RANGE LOOP + IF EVAL_ORDER(I) = FUNC THEN + RETURN I; + END IF; + END LOOP; + FAILED ("DID NOT FIND LETTER " & FUNC); + RETURN 0; + END POS_OF; + + +BEGIN + + + TEST ("C97115A", "CHECK THAT THE INDEX EXPRESSIONS ARE" & + " EVALUATED AFTER THE GUARDS BUT" & + " BEFORE THE RENDEZVOUS IS ATTEMPTED" ); + + + DECLARE + + + TASK T IS + + + ENTRY E ( BOOLEAN ); + ENTRY E1; + + END T; + + + TASK BODY T IS + BEGIN + + + WHILE E1'COUNT = 0 -- IF E1 NOT YET CALLED, THEN GIVE + LOOP -- THE MAIN TASK AN OPPORTUNITY + DELAY 10.01 * Impdef.One_Second; -- TO ISSUE THE CALL. + END LOOP; + + + SELECT + + ACCEPT E1; + + OR + + WHEN 6 + F1(7) = 13 => + ACCEPT E ( I1(17) ); + + OR + + WHEN 6 + F2(7) = 13 => + ACCEPT E ( I2(17) ); + + OR + + WHEN 6 + F3(7) = 13 => + ACCEPT E ( I3(17) ); + + END SELECT; + + + END T; + + + BEGIN + + T.E1; + + END; -- END OF BLOCK CONTAINING THE ENTRY CALLS + + + COMMENT ("GUARD AND INDEX FUNCTIONS WERE CALLED IN ORDER " & + EVAL_ORDER); + COMMENT ("GUARD AND INDEX EXPRESSIONS WERE EVALUATED IN THE " & + "ORDER " & EVAL_ORD); + + IF POS_OF ('F') > POS_OF ('A') OR + POS_OF ('G') > POS_OF ('B') OR + POS_OF ('H') > POS_OF ('C') THEN + FAILED ("AN INDEX EXPRESSION WAS EVALUATED TOO EARLY"); + END IF; + + RESULT; + +END C97115A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97116a.ada b/gcc/testsuite/ada/acats/tests/c9/c97116a.ada new file mode 100644 index 000000000..737d2528e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97116a.ada @@ -0,0 +1,102 @@ +-- C97116A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE GUARD CONDITIONS IN A SELECTIVE WAIT STATEMENT +-- ARE NOT RE-EVALUATED DURING THE WAIT. + +-- HISTORY: +-- WRG 7/10/86 CREATED ORIGINAL TEST. +-- RJW 5/15/90 REMOVED SHARED VARIABLES. + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C97116A IS + + GUARD_EVALUATIONS : NATURAL := 0; + + FUNCTION GUARD RETURN BOOLEAN IS + BEGIN + GUARD_EVALUATIONS := GUARD_EVALUATIONS + 1; + RETURN FALSE; + END GUARD; + + FUNCTION SO_LONG RETURN DURATION IS + BEGIN + RETURN 20.0; + END SO_LONG; + +BEGIN + + TEST ("C97116A", "CHECK THAT THE GUARD CONDITIONS IN A " & + "SELECTIVE WAIT STATEMENT ARE NOT RE-EVALUATED " & + "DURING THE WAIT"); + + DECLARE + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E; + FAILED ("ACCEPTED NONEXISTENT CALL TO E"); + OR WHEN GUARD => + DELAY 0.0; + FAILED ("EXECUTED ALTERNATIVE CLOSED BY FALSE " & + "GUARD FUNCTION" ); + OR + DELAY SO_LONG * Impdef.One_Second; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END T; + + TASK GET_CPU; + + TASK BODY GET_CPU IS + BEGIN + WHILE NOT T'TERMINATED LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + END GET_CPU; + + BEGIN + + NULL; + + END; + + IF GUARD_EVALUATIONS /= 1 THEN + FAILED ("GUARD EVALUATED" & + NATURAL'IMAGE(GUARD_EVALUATIONS) & " TIMES"); + END IF; + + RESULT; + +END C97116A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97117a.ada b/gcc/testsuite/ada/acats/tests/c9/c97117a.ada new file mode 100644 index 000000000..cf5e1b911 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97117a.ada @@ -0,0 +1,72 @@ +-- C97117A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT PROGRAM_ERROR IS RAISED IF ALL ALTERNATIVES ARE CLOSED AND +-- NO ELSE PART IS PRESENT. + +-- WRG 7/10/86 + +WITH REPORT; USE REPORT; +PROCEDURE C97117A IS + +BEGIN + + TEST ("C97117A", "CHECK THAT PROGRAM_ERROR IS RAISED IF ALL " & + "ALTERNATIVES ARE CLOSED AND NO ELSE PART IS " & + "PRESENT"); + + DECLARE + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + BEGIN + SELECT + WHEN IDENT_BOOL (FALSE) => + ACCEPT E; + FAILED ("CLOSED ACCEPT ALTERNATIVE TAKEN " & + "FOR NONEXISTENT ENTRY CALL"); + OR WHEN IDENT_BOOL (FALSE) => + DELAY 0.0; + FAILED ("CLOSED ALTERNATIVE TAKEN"); + END SELECT; + FAILED ("PROGRAM_ERROR NOT RAISED"); + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END T; + + BEGIN + + NULL; + + END; + + RESULT; + +END C97117A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97117b.ada b/gcc/testsuite/ada/acats/tests/c9/c97117b.ada new file mode 100644 index 000000000..bc05ebf35 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97117b.ada @@ -0,0 +1,88 @@ +-- C97117B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT AN ELSE PART IS EXECUTED IF ALL ALTERNATIVES ARE CLOSED OR +-- IF THERE ARE NO TASKS QUEUED FOR OPEN ALTERNATIVES. + +-- WRG 7/10/86 + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C97117B IS + +BEGIN + + TEST ("C97117B", "CHECK THAT AN ELSE PART IS EXECUTED IF ALL " & + "ALTERNATIVES ARE CLOSED OR IF THERE ARE NO " & + "TASKS QUEUED FOR OPEN ALTERNATIVES"); + + DECLARE + + TASK T IS + ENTRY E; + ENTRY NO_GO; + END T; + + TASK BODY T IS + BEGIN + -- ENSURE THAT NO_GO HAS BEEN CALLED BEFORE PROCEEDING: + WHILE NO_GO'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + SELECT + WHEN IDENT_BOOL (FALSE) => + ACCEPT E; + FAILED ("CLOSED ACCEPT ALTERNATIVE TAKEN " & + "FOR NONEXISTENT ENTRY CALL - 1"); + OR + WHEN IDENT_BOOL (FALSE) => + ACCEPT NO_GO; + FAILED ("CLOSED ALTERNATIVE TAKEN - 1"); + ELSE + COMMENT ("ELSE PART EXECUTED - 1"); + END SELECT; + + SELECT + ACCEPT E; + FAILED ("ACCEPTED NONEXISTENT ENTRY CALL - 2"); + OR WHEN IDENT_BOOL (FALSE) => + ACCEPT NO_GO; + FAILED ("CLOSED ALTERNATIVE TAKEN - 2"); + ELSE + COMMENT ("ELSE PART EXECUTED - 2"); + END SELECT; + + ACCEPT NO_GO; + END T; + + BEGIN + + T.NO_GO; + + END; + + RESULT; + +END C97117B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97117c.ada b/gcc/testsuite/ada/acats/tests/c9/c97117c.ada new file mode 100644 index 000000000..cda428029 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97117c.ada @@ -0,0 +1,74 @@ +-- C97117C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT AN ELSE PART IS NOT EXECUTED IF A TASK IS QUEUED AT AN +-- OPEN ALTERNATIVE. + +-- WRG 7/10/86 + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C97117C IS + +BEGIN + + TEST ("C97117C", "CHECK THAT AN ELSE PART IS NOT EXECUTED IF A " & + "TASK IS QUEUED AT AN OPEN ALTERNATIVE"); + + DECLARE + + TASK T IS + ENTRY E; + ENTRY NO_GO; + END T; + + TASK BODY T IS + BEGIN + --ENSURE THAT E HAS BEEN CALLED BEFORE PROCEEDING: + WHILE E'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + SELECT + ACCEPT NO_GO; + FAILED ("ACCEPTED NONEXISTENT ENTRY CALL"); + OR WHEN IDENT_BOOL (TRUE) => + ACCEPT E; + OR WHEN IDENT_BOOL (FALSE) => + ACCEPT E; + FAILED ("CLOSED ALTERNATIVE TAKEN"); + ELSE + FAILED ("ELSE PART EXECUTED"); + END SELECT; + END T; + + BEGIN + + T.E; + + END; + + RESULT; + +END C97117C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97118a.ada b/gcc/testsuite/ada/acats/tests/c9/c97118a.ada new file mode 100644 index 000000000..e1eceaf67 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97118a.ada @@ -0,0 +1,73 @@ +-- C97118A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A CALL TO A CLOSED ALTERNATIVE OF A SELECTIVE WAIT IS NOT +-- ACCEPTED. + +-- WRG 7/11/86 + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C97118A IS + +BEGIN + + TEST ("C97118A", "CHECK THAT A CALL TO A CLOSED ALTERNATIVE OF " & + "A SELECTIVE WAIT IS NOT ACCEPTED"); + + DECLARE + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + BEGIN + -- ENSURE THAT E HAS BEEN CALLED BEFORE PROCEEDING: + WHILE E'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + SELECT + WHEN IDENT_BOOL (FALSE) => + ACCEPT E; + FAILED ("ACCEPTED CALL TO CLOSED ALTERNATIVE"); + ELSE + NULL; + END SELECT; + + IF E'COUNT = 1 THEN + ACCEPT E; + END IF; + END T; + + BEGIN + + T.E; + + END; + + RESULT; + +END C97118A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97120a.ada b/gcc/testsuite/ada/acats/tests/c9/c97120a.ada new file mode 100644 index 000000000..4fd5293c1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97120a.ada @@ -0,0 +1,81 @@ +-- C97120A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A SELECTIVE WAIT DELAYS AT LEAST AS LONG AS IS SPECIFIED +-- IN A DELAY ALTERNATIVE. + +-- WRG 7/11/86 + +with Impdef; +WITH REPORT; USE REPORT; +WITH CALENDAR; USE CALENDAR; +PROCEDURE C97120A IS + +BEGIN + + TEST ("C97120A", "CHECK THAT A SELECTIVE WAIT DELAYS AT LEAST " & + "AS LONG AS IS SPECIFIED IN A DELAY ALTERNATIVE"); + + DECLARE + + TASK T IS + ENTRY NO_GO; + ENTRY SYNCH; + END T; + + TASK BODY T IS + BEFORE, AFTER : TIME; + BEGIN + -- ENSURE THAT SYNCH HAS BEEN CALLED BEFORE PROCEEDING: + WHILE SYNCH'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + BEFORE := CLOCK; + SELECT + ACCEPT NO_GO; + FAILED ("ACCEPTED NONEXISTENT ENTRY CALL"); + OR + DELAY 10.0 * Impdef.One_Second; + AFTER := CLOCK; + IF AFTER - BEFORE < 10.0 * Impdef.One_Second THEN + FAILED ("INSUFFICIENT DELAY"); + END IF; + END SELECT; + + ACCEPT SYNCH; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END T; + + BEGIN + + T.SYNCH; -- SUSPEND MAIN TASK BEFORE READING CLOCK. + + END; + + RESULT; + +END C97120A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97120b.ada b/gcc/testsuite/ada/acats/tests/c9/c97120b.ada new file mode 100644 index 000000000..5cc9806bb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97120b.ada @@ -0,0 +1,103 @@ +-- C97120B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF A SPECIFIED DELAY IS ZERO OR NEGATIVE AND AN ENTRY CALL +-- IS WAITING AT AN OPEN ALTERNATIVE WHEN THE SELECTIVE WAIT IS +-- EXECUTED, THE CALL IS ACCEPTED. + +-- WRG 7/11/86 + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C97120B IS + + ZERO, NEG : DURATION := 1.0; + +BEGIN + + TEST ("C97120B", "CHECK THAT IF A SPECIFIED DELAY IS ZERO OR " & + "NEGATIVE AND AN ENTRY CALL IS WAITING AT AN " & + "OPEN ALTERNATIVE WHEN THE SELECTIVE WAIT IS " & + "EXECUTED, THE CALL IS ACCEPTED"); + + IF EQUAL (3, 3) THEN + ZERO := 0.0; + NEG := -1.0; + END IF; + + DECLARE + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + BEGIN + WHILE E'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + A: BEGIN + SELECT + WHEN IDENT_BOOL (TRUE) => + ACCEPT E; + OR + DELAY ZERO * Impdef.One_Second; + FAILED ("ZERO DELAY ALTERNATIVE TAKEN"); + ACCEPT E; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED (A)"); + END A; + + WHILE E'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + B: BEGIN + SELECT + ACCEPT E; + OR + DELAY NEG; + FAILED ("NEGATIVE DELAY ALTERNATIVE TAKEN"); + ACCEPT E; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED (B)"); + END B; + + END T; + + BEGIN + + T.E; + T.E; + + END; + + RESULT; + +END C97120B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201a.ada b/gcc/testsuite/ada/acats/tests/c9/c97201a.ada new file mode 100644 index 000000000..18186cbc3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97201a.ada @@ -0,0 +1,151 @@ +-- C97201A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A RENDEZVOUS REQUESTED BY A CONDITIONAL_ENTRY_CALL +-- IS PERFORMED ONLY IF IMMEDIATELY POSSIBLE. + +-- CASE A: THE TASK TO BE CALLED IS NOT YET ACTIVE AS OF THE +-- MOMENT OF CALL (CONDITIONAL_ENTRY_CALL), +-- AND THIS FACT CAN BE DETERMINED STATICALLY. + + +-- RM 4/20/82 + + +WITH REPORT; USE REPORT; +PROCEDURE C97201A IS + + ELSE_BRANCH_TAKEN : INTEGER := 3 ; + +BEGIN + + + TEST ("C97201A", "CHECK THAT NO RENDEZVOUS REQUESTED BY" & + " A CONDITIONAL_ENTRY_CALL CAN OCCUR WHILE" & + " THE CALLED TASK IS NOT YET ACTIVE" ); + + + ------------------------------------------------------------------- + + + DECLARE + + + TASK T IS + ENTRY DO_IT_NOW_ORELSE ( AUTHORIZED : IN BOOLEAN ) ; + END T ; + + + TASK BODY T IS + + PACKAGE SECOND_ATTEMPT IS END SECOND_ATTEMPT ; + PACKAGE BODY SECOND_ATTEMPT IS + BEGIN + + SELECT + DO_IT_NOW_ORELSE (FALSE) ;--CALLING (OWN) ENTRY + ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY) + -- THEREFORE THIS BRANCH MUST BE CHOSEN + ELSE_BRANCH_TAKEN := 2 * ELSE_BRANCH_TAKEN ; + COMMENT( "ELSE_BRANCH TAKEN (#2)" ); + END SELECT; + + END SECOND_ATTEMPT ; + + BEGIN + + ACCEPT DO_IT_NOW_ORELSE ( AUTHORIZED : IN BOOLEAN ) DO + + IF AUTHORIZED THEN + COMMENT( "AUTHORIZED ENTRY_CALL" ); + ELSE + FAILED( "UNAUTHORIZED ENTRY_CALL" ); + END IF; + + END DO_IT_NOW_ORELSE ; + + + END T ; + + + PACKAGE FIRST_ATTEMPT IS END FIRST_ATTEMPT ; + PACKAGE BODY FIRST_ATTEMPT IS + BEGIN + SELECT + T.DO_IT_NOW_ORELSE (FALSE) ; + ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY) + -- THEREFORE THIS BRANCH MUST BE CHOSEN + ELSE_BRANCH_TAKEN := 1 + ELSE_BRANCH_TAKEN ; + COMMENT( "ELSE_BRANCH TAKEN (#1)" ); + END SELECT; + + END FIRST_ATTEMPT ; + + + BEGIN + + T.DO_IT_NOW_ORELSE ( TRUE ); -- TO SATISFY THE SERVER'S + -- WAIT FOR SUCH A CALL + + EXCEPTION + + WHEN TASKING_ERROR => + FAILED( "TASKING ERROR" ); + + END ; + + + ------------------------------------------------------------------- + + + -- BY NOW, THE TASK IS TERMINATED (AND THE NONLOCALS UPDATED) + + + CASE ELSE_BRANCH_TAKEN IS + + WHEN 3 => + FAILED( "NO 'ELSE'; BOTH (?) RENDEZVOUS ATTEMPTED?" ); + + WHEN 4 => + FAILED( "'ELSE' #1 ONLY; RENDEZVOUS (#2) ATTEMPTED?" ); + + WHEN 6 => + FAILED( "'ELSE' #2 ONLY; RENDEZVOUS (#1) ATTEMPTED?" ); + + WHEN 7 => + FAILED( "WRONG ORDER FOR 'ELSE': #2,#1 " ); + + WHEN 8 => + NULL ; + + WHEN OTHERS => + FAILED( "WRONG CASE_VALUE" ); + + END CASE; + + + RESULT; + + +END C97201A ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201b.ada b/gcc/testsuite/ada/acats/tests/c9/c97201b.ada new file mode 100644 index 000000000..d8e44b055 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97201b.ada @@ -0,0 +1,108 @@ +-- C97201B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A CONDITIONAL ENTRY CALL IS NOT ACCEPTED IF THERE IS +-- ANOTHER TASK QUEUED FOR THE ENTRY. + +-- WRG 7/11/86 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C97201B IS + + +BEGIN + + TEST ("C97201B", "CHECK THAT A CONDITIONAL ENTRY CALL IS NOT " & + "ACCEPTED IF THERE IS ANOTHER TASK QUEUED " & + "FOR THE ENTRY"); + + DECLARE + + TASK T IS + ENTRY E; + ENTRY SYNCH; + ENTRY DONE; + END T; + + TASK BODY T IS + BEGIN + -- ENSURE THAT E HAS BEEN CALLED BEFORE PROCEEDING: + WHILE E'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + ACCEPT SYNCH; + + SELECT + WHEN IDENT_BOOL (FALSE) => + ACCEPT E; + FAILED ("CLOSED ALTERNATIVE TAKEN"); + OR + ACCEPT DONE DO + IF E'COUNT /= 1 THEN + FAILED (NATURAL'IMAGE(E'COUNT) & + " CALLS WERE QUEUED FOR ENTRY " & + "E OF TASK T"); + END IF; + END DONE; + OR + DELAY 1000.0 * Impdef.One_Second; + FAILED ("DELAY EXPIRED; E'COUNT =" & + NATURAL'IMAGE(E'COUNT) ); + END SELECT; + + WHILE E'COUNT > 0 LOOP + ACCEPT E; + END LOOP; + END T; + + TASK AGENT; + + TASK BODY AGENT IS + BEGIN + T.E; + END AGENT; + + BEGIN + + T.SYNCH; + + DELAY 10.0 * Impdef.One_Second; + + SELECT + T.E; + FAILED ("CONDITIONAL ENTRY CALL ACCEPTED" ); + ELSE + COMMENT ("ELSE PART EXECUTED"); + T.DONE; + END SELECT; + + END; + + RESULT; + +END C97201B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201c.ada b/gcc/testsuite/ada/acats/tests/c9/c97201c.ada new file mode 100644 index 000000000..e09d01ee3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97201c.ada @@ -0,0 +1,70 @@ +-- C97201C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A CONDITIONAL ENTRY CALL IS NOT ACCEPTED IF AN ACCEPT +-- STATEMENT FOR THE CALLED ENTRY HAS NOT YET BEEN REACHED. + +-- WRG 7/11/86 + +WITH REPORT; USE REPORT; +PROCEDURE C97201C IS + +BEGIN + + TEST ("C97201C", "CHECK THAT A CONDITIONAL ENTRY CALL IS NOT " & + "ACCEPTED IF AN ACCEPT STATEMENT FOR THE " & + "CALLED ENTRY HAS NOT YET BEEN REACHED"); + + DECLARE + + TASK T IS + ENTRY E; + ENTRY BARRIER; + END T; + + TASK BODY T IS + BEGIN + ACCEPT BARRIER; + IF E'COUNT > 0 THEN + FAILED ("ENTRY CALL WAS QUEUED"); + ACCEPT E; + END IF; + END T; + + BEGIN + + SELECT + T.E; + FAILED ("CONDITIONAL ENTRY CALL ACCEPTED"); + ELSE + COMMENT ("ELSE PART EXECUTED"); + END SELECT; + + T.BARRIER; + + END; + + RESULT; + +END C97201C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201d.ada b/gcc/testsuite/ada/acats/tests/c9/c97201d.ada new file mode 100644 index 000000000..2ea7ba01a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97201d.ada @@ -0,0 +1,102 @@ +-- C97201D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A RENDEZVOUS REQUESTED BY A CONDITIONAL_ENTRY_CALL +-- IS PERFORMED ONLY IF IMMEDIATELY POSSIBLE. + +-- CASE D: THE BODY OF THE TASK CONTAINING THE CALLED ENTRY +-- DOES NOT CONTAIN AN ACCEPT_STATEMENT FOR THAT ENTRY - +-- AND THIS FACT IS DETERMINED STATICALLY. + + +-- RM 4/12/82 + + +WITH REPORT; USE REPORT; +PROCEDURE C97201D IS + + ELSE_BRANCH_TAKEN : BOOLEAN := FALSE ; + +BEGIN + + + TEST ("C97201D", "CHECK THAT NO RENDEZVOUS REQUESTED BY" & + " A CONDITIONAL_ENTRY_CALL CAN EVER OCCUR" & + " IN THE ABSENCE OF A CORRESPONDING " & + " ACCEPT_STATEMENT " ); + + + DECLARE + + + TASK T IS + ENTRY DO_IT_NOW_ORELSE ; + ENTRY KEEP_ALIVE ; + END T ; + + + TASK BODY T IS + BEGIN + + -- NO ACCEPT_STATEMENT FOR THE ENTRY_CALL BEING TESTED + + ACCEPT KEEP_ALIVE ; -- TO PREVENT THIS SERVER TASK FROM + -- TERMINATING IF + -- UPON ACTIVATION + -- IT GETS TO RUN + -- AHEAD OF THE CALLER (WHICH + -- WOULD LEAD TO A SUBSEQUENT + -- TASKING_ERROR AT THE TIME OF + -- THE NO-WAIT CALL). + + END ; + + + BEGIN + + SELECT + T.DO_IT_NOW_ORELSE ; + ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY) + -- THEREFORE THIS BRANCH MUST BE CHOSEN + ELSE_BRANCH_TAKEN := TRUE ; + COMMENT( "ELSE_BRANCH TAKEN" ); + END SELECT; + + T.KEEP_ALIVE ; -- THIS ALSO UPDATES THE NONLOCALS + + END; -- END OF BLOCK CONTAINING THE ENTRY CALL + + + -- BY NOW, THE TASK IS TERMINATED + + IF ELSE_BRANCH_TAKEN THEN + NULL ; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED?" ); + END IF; + + RESULT; + + +END C97201D ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201e.ada b/gcc/testsuite/ada/acats/tests/c9/c97201e.ada new file mode 100644 index 000000000..5473b572a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97201e.ada @@ -0,0 +1,107 @@ +-- C97201E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A RENDEZVOUS REQUESTED BY A CONDITIONAL_ENTRY_CALL +-- IS PERFORMED ONLY IF IMMEDIATELY POSSIBLE. + +-- CASE E: THE BODY OF THE TASK CONTAINING THE CALLED ENTRY +-- DOES NOT CONTAIN AN ACCEPT_STATEMENT FOR THAT ENTRY - +-- AND THIS FACT CAN NOT BE DETERMINED STATICALLY. +-- (THE ENTRY BELONGS TO AN ENTRY FAMILY; SOME FAMILY MEMBERS +-- ARE "ACCEPTABLE", BUT NOT THE CALLED ONE.) + + +-- RM 4/13/82 + + +WITH REPORT; USE REPORT; +PROCEDURE C97201E IS + + ELSE_BRANCH_TAKEN : BOOLEAN := FALSE ; + +BEGIN + + + TEST ("C97201E", "CHECK THAT NO RENDEZVOUS REQUESTED BY" & + " A CONDITIONAL_ENTRY_CALL CAN EVER OCCUR" & + " IN THE ABSENCE OF A CORRESPONDING " & + " ACCEPT_STATEMENT " ); + + + DECLARE + + SUBTYPE SHORT IS INTEGER RANGE 10..20 ; + + KEEP_ALIVE : INTEGER := 15 ; + + TASK T IS + ENTRY DO_IT_NOW_ORELSE ( SHORT ) ; + END T ; + + + TASK BODY T IS + BEGIN + + -- NO ACCEPT_STATEMENT FOR THE ENTRY_CALL BEING TESTED + ACCEPT DO_IT_NOW_ORELSE ( IDENT_INT(15) ); + + -- THIS ALSO PREVENTS THIS SERVER + -- TASK FROM TERMINATING IF + -- UPON ACTIVATION + -- IT GETS TO RUN + -- AHEAD OF THE CALLER (WHICH + -- WOULD LEAD TO A SUBSEQUENT + -- TASKING_ERROR AT THE TIME OF + -- THE NO-WAIT CALL). + + END ; + + + BEGIN + + SELECT + T.DO_IT_NOW_ORELSE (10) ; -- ACCEPT_STATEMENT HAS 15 + ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY) + -- THEREFORE THIS BRANCH MUST BE CHOSEN + ELSE_BRANCH_TAKEN := TRUE ; + COMMENT( "ELSE_BRANCH TAKEN" ); + END SELECT; + + T.DO_IT_NOW_ORELSE(KEEP_ALIVE) ;-- THIS ALSO UPDATES NONLOCALS + + END; -- END OF BLOCK CONTAINING THE ENTRY CALL + + + -- BY NOW, THE TASK IS TERMINATED + + IF ELSE_BRANCH_TAKEN THEN + NULL ; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED?" ); + END IF; + + RESULT; + + +END C97201E ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201g.ada b/gcc/testsuite/ada/acats/tests/c9/c97201g.ada new file mode 100644 index 000000000..ae5fad3bc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97201g.ada @@ -0,0 +1,133 @@ +-- C97201G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A RENDEZVOUS REQUESTED BY A CONDITIONAL_ENTRY_CALL +-- IS PERFORMED ONLY IF IMMEDIATELY POSSIBLE. + +-- CASE G: THE CORRESPONDING ACCEPT_STATEMENT IS CLOSED +-- AND THIS FACT IS STATICALLY DETERMINABLE. + + +-- RM 4/21/82 + + +WITH REPORT; USE REPORT; +PROCEDURE C97201G IS + + ELSE_BRANCH_TAKEN : BOOLEAN := FALSE ; + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE ; + QUEUE_NOT_EMPTY : BOOLEAN := FALSE ; + X : INTEGER := 17 ; + +BEGIN + + + TEST ("C97201G", "CHECK THAT NO RENDEZVOUS REQUESTED BY" & + " A CONDITIONAL_ENTRY_CALL CAN EVER OCCUR" & + " IF THE CORRESPONDING ACCEPT_STATEMENT IS" & + " CLOSED" ); + + + ------------------------------------------------------------------- + + + DECLARE + + + TASK T IS + ENTRY DO_IT_NOW_ORELSE( DID_YOU_DO_IT : IN OUT BOOLEAN); + ENTRY KEEP_ALIVE ; + END T ; + + + TASK BODY T IS + BEGIN + + IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN + QUEUE_NOT_EMPTY := TRUE ; + END IF; + + + SELECT + WHEN 3 = 5 => + ACCEPT DO_IT_NOW_ORELSE + ( DID_YOU_DO_IT : IN OUT BOOLEAN) + DO + DID_YOU_DO_IT := TRUE ; + END; + OR + ACCEPT KEEP_ALIVE ; -- TO PREVENT SELECT_ERROR + END SELECT; + + + IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN + QUEUE_NOT_EMPTY := TRUE ; + END IF; + + + END T ; + + + BEGIN + + COMMENT( "PERMANENTLY CLOSED" ); + + SELECT + T.DO_IT_NOW_ORELSE( RENDEZVOUS_OCCURRED ); + ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY) + -- THEREFORE THIS BRANCH MUST BE CHOSEN + ELSE_BRANCH_TAKEN := TRUE ; + COMMENT( "ELSE_BRANCH TAKEN" ); + END SELECT; + + T.KEEP_ALIVE ; -- THIS ALSO UPDATES THE NONLOCALS + + END; -- END OF BLOCK CONTAINING THE ENTRY CALL + + + ------------------------------------------------------------------- + + + -- BY NOW, THE TASK IS TERMINATED + + IF RENDEZVOUS_OCCURRED + THEN + FAILED( "RENDEZVOUS OCCURRED" ); + END IF; + + IF QUEUE_NOT_EMPTY + THEN + FAILED( "ENTRY QUEUE NOT EMPTY" ); + END IF; + + IF ELSE_BRANCH_TAKEN THEN + NULL ; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED?" ); + END IF; + + RESULT; + + +END C97201G ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201h.ada b/gcc/testsuite/ada/acats/tests/c9/c97201h.ada new file mode 100644 index 000000000..ad4a46189 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97201h.ada @@ -0,0 +1,133 @@ +-- C97201H.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A RENDEZVOUS REQUESTED BY A CONDITIONAL_ENTRY_CALL +-- IS PERFORMED ONLY IF IMMEDIATELY POSSIBLE. + +-- CASE H: THE CORRESPONDING ACCEPT_STATEMENT IS CLOSED +-- AND THIS FACT IS NOT STATICALLY DETERMINABLE. + + +-- RM 4/22/82 + + +WITH REPORT; USE REPORT; +PROCEDURE C97201H IS + + ELSE_BRANCH_TAKEN : BOOLEAN := FALSE ; + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE ; + QUEUE_NOT_EMPTY : BOOLEAN := FALSE ; + X : INTEGER := 17 ; + +BEGIN + + + TEST ("C97201H", "CHECK THAT NO RENDEZVOUS REQUESTED BY" & + " A CONDITIONAL_ENTRY_CALL CAN EVER OCCUR" & + " IF THE CORRESPONDING ACCEPT_STATEMENT IS" & + " CLOSED" ); + + + ------------------------------------------------------------------- + + + DECLARE + + + TASK T IS + ENTRY DO_IT_NOW_ORELSE( DID_YOU_DO_IT : IN OUT BOOLEAN); + ENTRY KEEP_ALIVE ; + END T ; + + + TASK BODY T IS + BEGIN + + IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN + QUEUE_NOT_EMPTY := TRUE ; + END IF; + + + SELECT + WHEN 3 = IDENT_INT(5) => + ACCEPT DO_IT_NOW_ORELSE + ( DID_YOU_DO_IT : IN OUT BOOLEAN) + DO + DID_YOU_DO_IT := TRUE ; + END; + OR + ACCEPT KEEP_ALIVE ; -- TO PREVENT SELECT_ERROR + END SELECT; + + + IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN + QUEUE_NOT_EMPTY := TRUE ; + END IF; + + + END T ; + + + BEGIN + + COMMENT( "PERMANENTLY CLOSED" ); + + SELECT + T.DO_IT_NOW_ORELSE( RENDEZVOUS_OCCURRED ); + ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY) + -- THEREFORE THIS BRANCH MUST BE CHOSEN + ELSE_BRANCH_TAKEN := TRUE ; + COMMENT( "ELSE_BRANCH TAKEN" ); + END SELECT; + + T.KEEP_ALIVE ; -- THIS ALSO UPDATES THE NONLOCALS + + END; -- END OF BLOCK CONTAINING THE ENTRY CALL + + + ------------------------------------------------------------------- + + + -- BY NOW, THE TASK IS TERMINATED + + IF RENDEZVOUS_OCCURRED + THEN + FAILED( "RENDEZVOUS OCCURRED" ); + END IF; + + IF QUEUE_NOT_EMPTY + THEN + FAILED( "ENTRY QUEUE NOT EMPTY" ); + END IF; + + IF ELSE_BRANCH_TAKEN THEN + NULL ; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED?" ); + END IF; + + RESULT; + + +END C97201H ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97201x.ada b/gcc/testsuite/ada/acats/tests/c9/c97201x.ada new file mode 100644 index 000000000..e7f74d982 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97201x.ada @@ -0,0 +1,170 @@ +-- C97201X.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT NO RENDEZVOUS CAN EVER OCCUR IF BOTH PARTNERS REFUSE TO +-- WAIT (THAT IS, IF THE ENTRY CALL IS ISSUED BY A +-- "CONDITIONAL_ENTRY_CALL" AND THUS FOLLOWS A NO-WAIT POLICY +-- (DEMANDING UNCONDITIONALLY THAT "YOU DO IT N O W , OR ELSE"), +-- WHILE THE CALLEE IS ALSO COMMITTED TO A NO-WAIT POLICY, +-- BY VIRTUE OF A SELECTIVE_WAIT STATEMENT OF THE THIRD KIND +-- (WITH AN "ELSE" PART) IN WHICH THE CORRESPONDING ACCEPT_STATEMENT +-- IS EMBEDDED). +-- ("CLOSE ENCOUNTERS OF THE THIRD KIND" -- ARE THEY POSSIBLE?) + + +-- THE SEMANTICS OF THIS ENTRY CALL REQUIRES THAT THE CALLING TASK +-- N O T ENTER ITSELF ON ANY QUEUE BUT RATHER ATTEMPT AN IMMEDIATE +-- RENDEZVOUS WHICH IS TO TAKE PLACE IF AND ONLY IF THE CALLED TASK +-- HAS REACHED A POINT WHERE IT IS READY TO ACCEPT THE CALL (I.E. +-- IT IS EITHER WAITING AT AN ACCEPT STATEMENT FOR THE CORRESPONDING +-- ENTRY OR IT IS WAITING AT A SELECTIVE_WAIT STATEMENT WITH AN OPEN +-- ALTERNATIVE STARTING WITH SUCH AN ACCEPT STATEMENT). IT ALSO +-- REQUIRES THAT THE ENTRY CALL BE CANCELLED IF THE CALLED TASK +-- IS NOT AT SUCH A POINT. ON THE OTHER HAND, THE SEMANTICS OF THE +-- SELECTIVE_WAIT STATEMENT WITH AN 'ELSE' PART SPECIFIES THAT +-- THE 'ELSE' PART MUST BE SELECTED IF NO 'ACCEPT' ALTERNATIVE +-- CAN BE IMMEDIATELY SELECTED, AND THAT SUCH AN ALTERNATIVE +-- IS DEEMED TO BE IMMEDIATELY SELECTABLE ("SELECTION OF ONE SUCH +-- ALTERNATIVE OCCURS IMMEDIATELY"), AND A CORRESPONDING RENDEZVOUS +-- POSSIBLE, IF AND ONLY IF THERE IS A CORRESPONDING ENTRY CALL +-- W A I T I N G TO BE ACCCEPTED. A "CONDITIONAL ENTRY CALL" +-- NEVER WAITS, AND IS NEVER ENTERED IN WAIT QUEUES; IT TAKES +-- THE 'ELSE' PART INSTEAD. + + +-- NOTE: IF THIS TEST PROGRAM HANGS UP, THE COMPILER WILL BE DEEMED +-- TO HAVE FAILED. + + +-- RM 3/19/82 + + +WITH REPORT; USE REPORT; +PROCEDURE C97201X IS + + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE ; + + CALLER_TAKES_WRONG_BRANCH : BOOLEAN := TRUE ; + SERVER_TAKES_WRONG_BRANCH : BOOLEAN := TRUE ; + QUEUE_NOT_EMPTY : BOOLEAN := FALSE ; + +BEGIN + + + TEST ("C97201X", "CHECK THAT NO RENDEZVOUS CAN EVER OCCUR IF" & + " BOTH PARTNERS REFUSE TO WAIT" ); + + + DECLARE + + + TASK T IS + ENTRY SYNCHRONIZE ; + ENTRY DO_IT_NOW_ORELSE( DID_YOU_DO_IT : IN OUT BOOLEAN); + ENTRY KEEP_ALIVE ; + END T ; + + + TASK BODY T IS + BEGIN + + + ACCEPT SYNCHRONIZE ; + + + IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN + QUEUE_NOT_EMPTY := TRUE ; + END IF; + + + SELECT + ACCEPT DO_IT_NOW_ORELSE + ( DID_YOU_DO_IT : IN OUT BOOLEAN ) + DO + DID_YOU_DO_IT := TRUE ; + END ; + ELSE -- (I.E. TASK ADOPTS NO-WAIT POLICY) + -- 'ELSE' BRANCH MUST THEREFORE BE CHOSEN + SERVER_TAKES_WRONG_BRANCH := FALSE ; + END SELECT; + + + IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN + QUEUE_NOT_EMPTY := TRUE ; + END IF; + + + ACCEPT KEEP_ALIVE ; -- TO PREVENT THIS SERVER TASK FROM + -- TERMINATING IF IT GETS TO + -- THE NO-WAIT MEETING-PLACE + -- AHEAD OF THE CALLER (WHICH + -- WOULD LEAD TO A SUBSEQUENT + -- TASKING_ERROR AT THE TIME OF + -- THE NO-WAIT CALL). + + + END T ; + + + BEGIN + + + T.SYNCHRONIZE ; -- TO MINIMIZE THE N E E D TO WAIT + + + SELECT + T.DO_IT_NOW_ORELSE ( RENDEZVOUS_OCCURRED ); + ELSE -- (I.E. CALLER TOO ADOPTS A NO-WAIT POLICY) + -- MUST THEREFORE CHOOSE THIS BRANCH + CALLER_TAKES_WRONG_BRANCH := FALSE ; + END SELECT; + + + T.KEEP_ALIVE ; -- THIS ALSO UPDATES THE NONLOCALS + + + END; -- END OF BLOCK CONTAINING THE NO-WAIT ENTRY CALL + + + IF RENDEZVOUS_OCCURRED + THEN + FAILED( "RENDEZVOUS OCCURRED" ); + END IF; + + IF CALLER_TAKES_WRONG_BRANCH OR + SERVER_TAKES_WRONG_BRANCH + THEN + FAILED( "WRONG BRANCH TAKEN" ); + END IF; + + IF QUEUE_NOT_EMPTY + THEN + FAILED( "ENTRY QUEUE NOT EMPTY" ); + END IF; + + + RESULT; + + +END C97201X ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97202a.ada b/gcc/testsuite/ada/acats/tests/c9/c97202a.ada new file mode 100644 index 000000000..3856e7fd2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97202a.ada @@ -0,0 +1,100 @@ +-- C97202A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE INDEX IS EVALUATED BEFORE THE ENTRY PARAMETER AND BOTH +-- THE INDEX AND THE ENTRY PARAMETER ARE EVALUATED BEFORE THE RENDEZVOUS +-- IS ATTEMPED. + +-- RM 4/05/82 +-- TBN 2/3/86 ADDED A CHECK THAT INDEX IS EVALUATED BEFORE THE ENTRY +-- PARAMETER AND FIXED APPROPRIATE COMMENTS. + +WITH REPORT; USE REPORT; +PROCEDURE C97202A IS + + INDEX_COMPUTED : BOOLEAN := FALSE ; + FORMAL_COMPUTED : BOOLEAN := FALSE ; + +BEGIN + + TEST ("C97202A", "CHECK THAT THE INDEX IS EVALUATED BEFORE THE " & + "ENTRY PARAMETER AND BOTH INDEX AND THE ENTRY " & + "PARAMETER ARE EVALUATED BEFORE THE RENDEZVOUS " & + "IS ATTEMPTED"); + + DECLARE + SUBTYPE SHORT IS INTEGER RANGE 10..20 ; + + TASK T IS + ENTRY DO_IT_NOW_ORELSE (SHORT) + (DID_YOU_DO_IT : IN BOOLEAN); + ENTRY KEEP_ALIVE ; + END T ; + + TASK BODY T IS + BEGIN + ACCEPT KEEP_ALIVE ; + END T ; + + FUNCTION F1 (X:INTEGER) RETURN INTEGER IS + BEGIN + IF FORMAL_COMPUTED THEN + FAILED ("INDEX WAS NOT EVALUATED FIRST"); + END IF; + INDEX_COMPUTED := TRUE ; + RETURN (7) ; + END F1 ; + + FUNCTION F2 (X:INTEGER) RETURN BOOLEAN IS + BEGIN + FORMAL_COMPUTED := TRUE ; + RETURN (FALSE) ; + END F2 ; + + BEGIN + SELECT + T.DO_IT_NOW_ORELSE ( 6 + F1(7) ) + ( NOT(F2(7)) ) ; + ELSE + NULL ; + END SELECT; + + T.KEEP_ALIVE ; + END; -- END OF BLOCK CONTAINING THE ENTRY CALLS. + + IF INDEX_COMPUTED THEN + NULL ; + ELSE + FAILED( "ENTRY INDEX WAS NOT COMPUTED" ); + END IF; + + IF FORMAL_COMPUTED THEN + NULL ; + ELSE + FAILED( "ENTRY PARAMETER WAS NOT COMPUTED" ); + END IF; + + RESULT; + +END C97202A ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97203a.ada b/gcc/testsuite/ada/acats/tests/c9/c97203a.ada new file mode 100644 index 000000000..64510dd9e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97203a.ada @@ -0,0 +1,125 @@ +-- C97203A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A CONDITIONAL_ENTRY_CALL CAN APPEAR IN PLACES WHERE A +-- SELECTIVE_WAIT CANNOT. + +-- PART 1: PACKAGE BODY EMBEDDED IN TASK BODY. + + +-- RM 4/01/1982 + + +WITH REPORT; +USE REPORT; +PROCEDURE C97203A IS + + +BEGIN + + + TEST ( "C97203A" , "CHECK THAT A CONDITIONAL_ENTRY_CALL CAN" & + " APPEAR WHERE A SELECTIVE_WAIT CANNOT" ); + + + ------------------------------------------------------------------- + + + DECLARE + + + TASK TT IS + ENTRY A ( AUTHORIZED : IN BOOLEAN ); + END TT ; + + + TASK BODY TT IS + + + PACKAGE WITHIN_TASK_BODY IS + -- NOTHING HERE + END WITHIN_TASK_BODY ; + + + PACKAGE BODY WITHIN_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + A ( FALSE ) ; -- CALLING (OWN) ENTRY + ELSE + COMMENT( "ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END WITHIN_TASK_BODY ; + + + BEGIN + + ACCEPT A ( AUTHORIZED : IN BOOLEAN ) DO + + IF AUTHORIZED THEN + COMMENT( "AUTHORIZED ENTRY_CALL" ); + ELSE + FAILED( "UNAUTHORIZED ENTRY_CALL" ); + END IF; + + END A ; + + END TT ; + + + PACKAGE OUTSIDE_TASK_BODY IS + -- NOTHING HERE + END OUTSIDE_TASK_BODY ; + + + PACKAGE BODY OUTSIDE_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + TT.A ( FALSE ) ; -- UNBORN + ELSE + COMMENT( "(OUT:) ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END OUTSIDE_TASK_BODY ; + + + BEGIN + + TT.A ( TRUE ); + + EXCEPTION + + WHEN TASKING_ERROR => + FAILED( "TASKING ERROR" ); + + END ; + + ------------------------------------------------------------------- + + RESULT ; + + +END C97203A ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97203b.ada b/gcc/testsuite/ada/acats/tests/c9/c97203b.ada new file mode 100644 index 000000000..089815495 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97203b.ada @@ -0,0 +1,131 @@ +-- C97203B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A CONDITIONAL_ENTRY_CALL CAN APPEAR IN PLACES WHERE A +-- SELECTIVE_WAIT CANNOT. + +-- PART 2: PROCEDURE BODY EMBEDDED IN TASK BODY. + + +-- RM 4/09/1982 + + +WITH REPORT; +USE REPORT; +PROCEDURE C97203B IS + + +BEGIN + + + TEST ( "C97203B" , "CHECK THAT A CONDITIONAL_ENTRY_CALL CAN" & + " APPEAR WHERE A SELECTIVE_WAIT CANNOT" ); + + + ------------------------------------------------------------------- + + + DECLARE + + + TASK TT IS + ENTRY A ( AUTHORIZED : IN BOOLEAN ); + END TT ; + + + TASK BODY TT IS + + + PROCEDURE WITHIN_TASK_BODY ; + + + PROCEDURE WITHIN_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + A ( FALSE ) ; -- CALLING (OWN) ENTRY + ELSE + COMMENT( "ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END WITHIN_TASK_BODY ; + + + BEGIN + + + -- CALL THE INNER PROC. TO FORCE EXEC. OF COND_E_CALL + WITHIN_TASK_BODY ; + + + ACCEPT A ( AUTHORIZED : IN BOOLEAN ) DO + + IF AUTHORIZED THEN + COMMENT( "AUTHORIZED ENTRY_CALL" ); + ELSE + FAILED( "UNAUTHORIZED ENTRY_CALL" ); + END IF; + + END A ; + + END TT ; + + + PROCEDURE OUTSIDE_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + TT.A ( FALSE ) ; -- UNBORN + ELSE + COMMENT( "(OUT:) ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END OUTSIDE_TASK_BODY ; + + + PACKAGE CREATE_OPPORTUNITY_TO_CALL IS END; + PACKAGE BODY CREATE_OPPORTUNITY_TO_CALL IS + BEGIN + -- CALL THE OTHER PROC. TO FORCE EXEC. OF COND_E_CALL + OUTSIDE_TASK_BODY ; + END CREATE_OPPORTUNITY_TO_CALL ; + + + BEGIN + + TT.A ( TRUE ); + + EXCEPTION + + WHEN TASKING_ERROR => + FAILED( "TASKING ERROR" ); + + END ; + + ------------------------------------------------------------------- + + RESULT ; + + +END C97203B ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97203c.ada b/gcc/testsuite/ada/acats/tests/c9/c97203c.ada new file mode 100644 index 000000000..d8d9bf5a8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97203c.ada @@ -0,0 +1,124 @@ +-- C97203C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A CONDITIONAL ENTRY CALL CAN APPEAR IN PLACES WHERE A +-- SELECTIVE WAIT IS NOT ALLOWED. + +-- PART 3: TASK BODY NESTED WITHIN A TASK. + +-- WRG 7/15/86 + +WITH REPORT; USE REPORT; +PROCEDURE C97203C IS + +BEGIN + + TEST ("C97203C", "CHECK THAT A CONDITIONAL ENTRY CALL CAN " & + "APPEAR IN PLACES WHERE A SELECTIVE WAIT " & + "IS NOT ALLOWED; CASE: TASK BODY NESTED " & + "WITHIN A TASK"); + + DECLARE + + TASK T IS + ENTRY E; + ENTRY SYNCH; + END T; + + TASK BODY T IS + BEGIN + ACCEPT SYNCH; + ACCEPT SYNCH; + ACCEPT SYNCH; + ACCEPT E; + END T; + + TASK OUTER IS + ENTRY E; + ENTRY SYNCH; + END OUTER; + + TASK BODY OUTER IS + + TASK TYPE INNER; + + INNER1 : INNER; + + TASK BODY INNER IS + BEGIN + SELECT + T.E; + FAILED ("CONDITIONAL ENTRY CALL ACCEPTED - " & + "INNER (1)"); + ELSE + T.SYNCH; + END SELECT; + + SELECT + OUTER.E; + FAILED ("CONDITIONAL ENTRY CALL ACCEPTED - " & + "INNER (2)"); + ELSE + OUTER.SYNCH; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - INNER"); + END INNER; + + PACKAGE DUMMY IS + TYPE ACC_INNER IS ACCESS INNER; + INNER2 : ACC_INNER := NEW INNER; + END DUMMY; + + BEGIN + + SELECT + T.E; + FAILED ("CONDITIONAL ENTRY CALL ACCEPTED - OUTER"); + ELSE + T.SYNCH; + END SELECT; + + ACCEPT SYNCH; + ACCEPT SYNCH; + ACCEPT E; + + EXCEPTION + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - OUTER"); + + END OUTER; + + BEGIN + + T.E; + OUTER.E; + + END; + + RESULT; + +END C97203C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97204a.ada b/gcc/testsuite/ada/acats/tests/c9/c97204a.ada new file mode 100644 index 000000000..a1913a0b3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97204a.ada @@ -0,0 +1,122 @@ +-- C97204A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE EXCEPTION TASKING_ERROR WILL BE RAISED IF THE CALLED +-- TASK HAS ALREADY COMPLETED ITS EXECUTION AT THE TIME OF THE +-- CONDITIONAL_ENTRY_CALL. + + +-- RM 5/28/82 +-- SPS 11/21/82 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C97204A IS + + -- THE TASK WILL HAVE HIGHER PRIORITY ( PRIORITY'LAST ) + +BEGIN + + + ------------------------------------------------------------------- + + + TEST ("C97204A", "CHECK THAT THE EXCEPTION TASKING_ERROR WILL" & + " BE RAISED IF THE CALLED TASK HAS ALREADY" & + " COMPLETED ITS EXECUTION AT THE TIME OF THE" & + " CONDITIONAL_ENTRY_CALL" ); + + + DECLARE + + + TASK TYPE T_TYPE IS + + + ENTRY E ; + + END T_TYPE ; + + + T_OBJECT1 : T_TYPE ; + + + TASK BODY T_TYPE IS + BUSY : BOOLEAN := FALSE ; + BEGIN + + NULL; + + END T_TYPE ; + + + BEGIN + + + FOR I IN 1..5 LOOP + EXIT WHEN T_OBJECT1'TERMINATED ; + DELAY 10.0 * Impdef.One_Second; + END LOOP; + + + IF NOT T_OBJECT1'TERMINATED THEN + COMMENT( "TASK NOT YET TERMINATED (AFTER 50 S.)" ); + END IF; + + + BEGIN + + SELECT + T_OBJECT1.E ; + FAILED( "CALL WAS NOT DISOBEYED" ); + ELSE + FAILED( "'ELSE' BRANCH TAKEN INSTEAD OF TSKG_ERR" ); + END SELECT; + + FAILED( "EXCEPTION NOT RAISED" ); + + EXCEPTION + + WHEN TASKING_ERROR => + NULL ; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED" ); + + END ; + + + END ; + + + ------------------------------------------------------------------- + + + + RESULT; + + +END C97204A ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97204b.ada b/gcc/testsuite/ada/acats/tests/c9/c97204b.ada new file mode 100644 index 000000000..9e52a9deb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97204b.ada @@ -0,0 +1,82 @@ +-- C97204B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT TASKING_ERROR IS RAISED IF THE CALLED TASK IS ABORTED +-- BEFORE THE CONDITIONAL ENTRY CALL IS EXECUTED. + +-- WRG 7/13/86 + +WITH REPORT; USE REPORT; +PROCEDURE C97204B IS + +BEGIN + + TEST ("C97204B", "CHECK THAT TASKING_ERROR IS RAISED IF THE " & + "CALLED TASK IS ABORTED BEFORE THE CONDITIONAL " & + "ENTRY CALL IS EXECUTED"); + + DECLARE + + TASK T IS + ENTRY E (I : INTEGER); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (I : INTEGER); + FAILED ("ENTRY CALL ACCEPTED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END T; + + FUNCTION F RETURN INTEGER IS + BEGIN + ABORT T; + RETURN 1; + END F; + + BEGIN + + SELECT + T.E (F); + FAILED ("CONDITIONAL ENTRY CALL MADE"); + ELSE + FAILED ("ELSE PART EXECUTED"); + END SELECT; + + FAILED ("EXCEPTION NOT RAISED"); + + EXCEPTION + + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + + END; + + RESULT; + +END C97204B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97205a.ada b/gcc/testsuite/ada/acats/tests/c9/c97205a.ada new file mode 100644 index 000000000..a0bd4d9b2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97205a.ada @@ -0,0 +1,94 @@ +-- C97205A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY POSSIBLE (FOR A +-- CONDITIONAL ENTRY CALL), IT IS PERFORMED. + +-- CASE A: SINGLE ENTRY; THE CALLED TASK IS EXECUTING AN ACCEPT +-- STATEMENT. + +-- WRG 7/13/86 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C97205A IS + + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE; + STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE; + COUNT : POSITIVE := 1; + + +BEGIN + + TEST ("C97205A", "CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY " & + "POSSIBLE (FOR A CONDITIONAL ENTRY CALL), IT " & + "IS PERFORMED"); + + DECLARE + + TASK T IS + ENTRY E (B : IN OUT BOOLEAN); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (B : IN OUT BOOLEAN) DO + B := IDENT_BOOL (TRUE); + END E; + END T; + + BEGIN + + WHILE NOT STATEMENTS_AFTER_CALL_EXECUTED LOOP + DELAY 1.0 * Impdef.One_Second; + + SELECT + T.E (RENDEZVOUS_OCCURRED); + STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE); + ELSE + IF COUNT < 60 * 60 THEN + COUNT := COUNT + 1; + ELSE + FAILED ("NO RENDEZVOUS AFTER AT LEAST ONE " & + "HOUR ELAPSED"); + EXIT; + END IF; + END SELECT; + END LOOP; + + END; + + IF NOT RENDEZVOUS_OCCURRED THEN + FAILED ("RENDEZVOUS DID NOT OCCUR"); + END IF; + + IF COUNT > 1 THEN + COMMENT ("DELAYED" & POSITIVE'IMAGE(COUNT) & " SECONDS"); + END IF; + + RESULT; + +END C97205A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97205b.ada b/gcc/testsuite/ada/acats/tests/c9/c97205b.ada new file mode 100644 index 000000000..ec49ad577 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97205b.ada @@ -0,0 +1,98 @@ +-- C97205B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY POSSIBLE (FOR A +-- CONDITIONAL ENTRY CALL), IT IS PERFORMED. + +-- CASE B: ENTRY FAMILY; THE CALLED TASK IS EXECUTING A SELECTIVE WAIT. + +-- WRG 7/13/86 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C97205B IS + + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE; + STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE; + COUNT : POSITIVE := 1; + + +BEGIN + + TEST ("C97205B", "CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY " & + "POSSIBLE (FOR A CONDITIONAL ENTRY CALL), IT " & + "IS PERFORMED"); + + DECLARE + + TASK T IS + ENTRY E (1..3) (B : IN OUT BOOLEAN); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E (2) (B : IN OUT BOOLEAN) DO + B := IDENT_BOOL (TRUE); + END E; + OR + ACCEPT E (3) (B : IN OUT BOOLEAN); + FAILED ("NONEXISTENT ENTRY CALL ACCEPTED"); + END SELECT; + END T; + + BEGIN + + WHILE NOT STATEMENTS_AFTER_CALL_EXECUTED LOOP + DELAY 1.0 * Impdef.One_Second; + + SELECT + T.E (2) (RENDEZVOUS_OCCURRED); + STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE); + ELSE + IF COUNT < 60 * 60 THEN + COUNT := COUNT + 1; + ELSE + FAILED ("NO RENDEZVOUS AFTER AT LEAST ONE " & + "HOUR ELAPSED"); + EXIT; + END IF; + END SELECT; + END LOOP; + + END; + + IF NOT RENDEZVOUS_OCCURRED THEN + FAILED ("RENDEZVOUS DID NOT OCCUR"); + END IF; + + IF COUNT > 1 THEN + COMMENT ("DELAYED" & POSITIVE'IMAGE(COUNT) & " SECONDS"); + END IF; + + RESULT; + +END C97205B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97301a.ada b/gcc/testsuite/ada/acats/tests/c9/c97301a.ada new file mode 100644 index 000000000..81c65fb11 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97301a.ada @@ -0,0 +1,158 @@ +-- C97301A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT LEAST THE SPECIFIED +-- AMOUNT OF TIME IF A RENDEVOUS IS NOT POSSIBLE. + +-- CASE A: THE TASK TO BE CALLED HAS NOT YET BEEN ACTIVATED AS OF THE +-- MOMENT OF CALL. + +-- RJW 3/31/86 + +with Impdef; +WITH REPORT; USE REPORT; +WITH CALENDAR; USE CALENDAR; +PROCEDURE C97301A IS + + WAIT_TIME : CONSTANT DURATION := 10.0 * Impdef.One_Second; + OR_BRANCH_TAKEN : INTEGER := 3; + +BEGIN + + TEST ("C97301A", "CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT " & + "LEAST THE SPECIFIED AMOUNT OF TIME WHEN THE " & + "CALLED TASK IS NOT ACTIVE" ); + + ------------------------------------------------------------------ + + DECLARE + + TASK T IS + ENTRY DO_IT_NOW_OR_WAIT ( AUTHORIZED : IN BOOLEAN ); + END T; + + TASK BODY T IS + + PACKAGE SECOND_ATTEMPT IS END SECOND_ATTEMPT; + PACKAGE BODY SECOND_ATTEMPT IS + START_TIME : TIME; + BEGIN + START_TIME := CLOCK; + SELECT + DO_IT_NOW_OR_WAIT (FALSE); --CALLING OWN ENTRY. + OR + -- THEREFORE THIS BRANCH + -- MUST BE CHOSEN. + DELAY WAIT_TIME; + IF CLOCK >= (WAIT_TIME + START_TIME) THEN + NULL; + ELSE + FAILED ( "INSUFFICIENT DELAY (#2)" ); + END IF; + OR_BRANCH_TAKEN := 2 * OR_BRANCH_TAKEN; + COMMENT( "OR_BRANCH TAKEN (#2)" ); + END SELECT; + END SECOND_ATTEMPT; + + BEGIN + + ACCEPT DO_IT_NOW_OR_WAIT ( AUTHORIZED : IN BOOLEAN ) DO + + IF AUTHORIZED THEN + COMMENT( "AUTHORIZED ENTRY_CALL" ); + ELSE + FAILED( "UNAUTHORIZED ENTRY_CALL" ); + END IF; + + END DO_IT_NOW_OR_WAIT; + + + END T; + + + PACKAGE FIRST_ATTEMPT IS END FIRST_ATTEMPT; + PACKAGE BODY FIRST_ATTEMPT IS + START_TIME : TIME; + BEGIN + START_TIME := CLOCK; + SELECT + T.DO_IT_NOW_OR_WAIT (FALSE); + OR + -- THIS BRANCH MUST BE CHOSEN. + DELAY WAIT_TIME; + IF CLOCK >= (WAIT_TIME + START_TIME) THEN + NULL; + ELSE + FAILED ( "INSUFFICIENT DELAY (#1)" ); + END IF; + OR_BRANCH_TAKEN := 1 + OR_BRANCH_TAKEN; + COMMENT( "OR_BRANCH TAKEN (#1)" ); + END SELECT; + + END FIRST_ATTEMPT; + + BEGIN + + T.DO_IT_NOW_OR_WAIT ( TRUE ); -- TO SATISFY THE SERVER'S + -- WAIT FOR SUCH A CALL. + + EXCEPTION + + WHEN TASKING_ERROR => + FAILED( "TASKING ERROR" ); + + END ; + + + ------------------------------------------------------------------ + + + -- BY NOW, THE TASK IS TERMINATED (AND THE NONLOCALS UPDATED). + + + CASE OR_BRANCH_TAKEN IS + + WHEN 3 => + FAILED( "NO 'OR'; BOTH (?) RENDEZVOUS ATTEMPTED?" ); + + WHEN 4 => + FAILED( "'OR' #1 ONLY; RENDEZVOUS (#2) ATTEMPTED?" ); + + WHEN 6 => + FAILED( "'OR' #2 ONLY; RENDEZVOUS (#1) ATTEMPTED?" ); + + WHEN 7 => + FAILED( "WRONG ORDER FOR 'OR': #2,#1" ); + + WHEN 8 => + NULL; + + WHEN OTHERS => + FAILED( "WRONG CASE_VALUE" ); + + END CASE; + + RESULT; + +END C97301A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97301b.ada b/gcc/testsuite/ada/acats/tests/c9/c97301b.ada new file mode 100644 index 000000000..f6dead392 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97301b.ada @@ -0,0 +1,147 @@ +-- C97301B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT LEAST THE SPECIFIED +-- AMOUNT OF TIME IF A RENDEZVOUS IS NOT POSSIBLE. + +-- CASE B: THE QUEUE FOR THE CALLED ENTRY ALREADY CONTAINS +-- ANOTHER TASK WHOSE RENDEZVOUS CANNOT BE COMPLETED WITHIN +-- THE SPECIFIED DELAY. + +--HISTORY: +-- RJW 03/31/86 CREATED ORIGINAL TEST. +-- DHH 10/20/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + +with Impdef; +WITH REPORT; USE REPORT; +WITH CALENDAR; USE CALENDAR; +PROCEDURE C97301B IS + + OR_BRANCH_TAKEN : BOOLEAN := FALSE; + +BEGIN + + TEST ("C97301B", "CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT " & + "LEAST THE SPECIFIED AMOUNT OF TIME WHEN THE " & + "QUEUE FOR THE CALLED ENTRY ALREADY CONTAINS " & + "ANOTHER TASK WHOSE RENDEZVOUS CANNOT BE " & + "COMPLETED WITHIN THE SPECIFIED DELAY" ); + + + DECLARE + WAIT_TIME : DURATION := 3.0 * Impdef.One_Second; + + TASK T1; + + TASK T2 IS + ENTRY AWAKEN_T2; + END T2; + + TASK T3 IS + ENTRY AWAKEN_T3; + ENTRY RELEASE_T; + END T3; + + TASK T IS + ENTRY DO_IT_NOW_OR_WAIT (X : INTEGER); + END T; + + TASK BODY T IS + BEGIN + ACCEPT DO_IT_NOW_OR_WAIT (X : INTEGER) DO + IF X = 1 THEN + T2.AWAKEN_T2; + WHILE DO_IT_NOW_OR_WAIT'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + T3.AWAKEN_T3; + T3.RELEASE_T; + ELSE + FAILED ("WRONG TASK IN RENDEZVOUS - 1"); + END IF; + END DO_IT_NOW_OR_WAIT; + ACCEPT DO_IT_NOW_OR_WAIT (X : INTEGER) DO + IF X /= 2 THEN + FAILED ("WRONG TASK IN RENDEZVOUS - 2"); + END IF; + END DO_IT_NOW_OR_WAIT; + END T; + + TASK BODY T1 IS + BEGIN + T.DO_IT_NOW_OR_WAIT (1); + END T1; + + TASK BODY T2 IS + BEGIN + ACCEPT AWAKEN_T2; + T.DO_IT_NOW_OR_WAIT (2); + END T2; + + TASK BODY T3 IS + START_TIME : TIME; + STOP_TIME : TIME; + BEGIN + BEGIN + ACCEPT AWAKEN_T3; + START_TIME := CLOCK; + SELECT + T.DO_IT_NOW_OR_WAIT (3); + OR + -- THIS BRANCH MUST BE CHOSEN. + DELAY WAIT_TIME; + STOP_TIME := CLOCK; + IF STOP_TIME >= (WAIT_TIME + START_TIME) THEN + NULL; + ELSE + FAILED ( "INSUFFICIENT DELAY" ); + END IF; + OR_BRANCH_TAKEN := TRUE; + COMMENT( "OR_BRANCH TAKEN" ); + ACCEPT RELEASE_T; + END SELECT; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ( "TASKING ERROR" ); + END; + -- END OF BLOCK CONTAINING TIMED + -- ENTRY CALL. + + -- BY NOW, THE TASK T IS EFFECTIVELY + -- TERMINATED (AND THE NONLOCALS UPDATED). + + IF OR_BRANCH_TAKEN THEN + NULL; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED" ); + END IF; + END T3; + BEGIN + NULL; + END; + + RESULT; + +END C97301B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97301c.ada b/gcc/testsuite/ada/acats/tests/c9/c97301c.ada new file mode 100644 index 000000000..a2b3abbc0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97301c.ada @@ -0,0 +1,101 @@ +-- C97301C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT LEAST THE SPECIFIED +-- AMOUNT OF TIME IF A RENDEVOUS IS NOT POSSIBLE. + +-- CASE C: AN ACCEPT STATEMENT FOR THE CALLED ENTRY HAS NOT BEEN +-- REACHED. + +-- RJW 3/31/86 + +with Impdef; +WITH REPORT; USE REPORT; +WITH CALENDAR; USE CALENDAR; +PROCEDURE C97301C IS + + OR_BRANCH_TAKEN : BOOLEAN := FALSE; + +BEGIN + + TEST ("C97301C", "CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT " & + "LEAST THE SPECIFIED AMOUNT OF TIME WHEN AN " & + "ACCEPT STATEMENT FOR THE CALLED ENTRY HAS " & + "NOT BEEN REACHED" ); + + + DECLARE + START_TIME : TIME; + STOP_TIME : TIME; + WAIT_TIME : DURATION := 3.0 * Impdef.One_Second; + + TASK T IS + ENTRY NO_SPIN; + ENTRY DO_IT_NOW_OR_WAIT; + END T; + + TASK BODY T IS + BEGIN + ACCEPT NO_SPIN; + ACCEPT DO_IT_NOW_OR_WAIT; + END T; + + BEGIN + START_TIME := CLOCK; + SELECT + T.DO_IT_NOW_OR_WAIT; + FAILED("RENDEZVOUS OCCURRED"); + ABORT T; + OR + -- THIS BRANCH MUST BE CHOSEN. + DELAY WAIT_TIME; + STOP_TIME := CLOCK; + IF STOP_TIME >= (WAIT_TIME + START_TIME) THEN + NULL; + ELSE + FAILED ( "INSUFFICIENT DELAY" ); + END IF; + T.NO_SPIN; + OR_BRANCH_TAKEN := TRUE; + COMMENT( "OR_BRANCH TAKEN" ); + T.DO_IT_NOW_OR_WAIT; + END SELECT; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ( "TASKING ERROR" ); + END; + -- END OF BLOCK CONTAINING TIMED + -- ENTRY CALL. + + -- BY NOW, TASK T IS TERMINATED (AND THE NONLOCALS UPDATED). + + IF OR_BRANCH_TAKEN THEN + NULL; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED" ); + END IF; + + RESULT; + +END C97301C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97301d.ada b/gcc/testsuite/ada/acats/tests/c9/c97301d.ada new file mode 100644 index 000000000..e473fa772 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97301d.ada @@ -0,0 +1,106 @@ +-- C97301D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT LEAST THE SPECIFIED +-- AMOUNT OF TIME IF A RENDEVOUS IS NOT POSSIBLE. + +-- CASE D: THE BODY OF THE TASK CONTAINING THE CALLED ENTRY +-- DOES NOT CONTAIN AN ACCEPT_STATEMENT FOR THAT ENTRY. + +-- RJW 3/31/86 + +with Impdef; +WITH REPORT; USE REPORT; +WITH CALENDAR; USE CALENDAR; +PROCEDURE C97301D IS + + OR_BRANCH_TAKEN : BOOLEAN := FALSE; + +BEGIN + + TEST ("C97301D", "CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT " & + "LEAST THE SPECIFIED AMOUNT OF TIME WHEN THE " & + "BODY OF THE TASK CONTAINING THE CALLED ENTRY " & + "DOES NOT CONTAIN AN ACCEPT_STATEMENT FOR " & + "THAT ENTRY" ); + + DECLARE + START_TIME : TIME; + WAIT_TIME : CONSTANT DURATION := 10.0 * Impdef.One_Second; + + TASK T IS + ENTRY DO_IT_NOW_OR_WAIT; + ENTRY KEEP_ALIVE; + END T; + + TASK BODY T IS + BEGIN + + -- NO ACCEPT_STATEMENT FOR THE ENTRY_CALL BEING TESTED. + + ACCEPT KEEP_ALIVE; -- TO PREVENT THIS SERVER TASK FROM + -- TERMINATING IF + -- UPON ACTIVATION + -- IT GETS TO RUN + -- AHEAD OF THE CALLER (WHICH + -- WOULD LEAD TO A SUBSEQUENT + -- TASKING_ERROR AT THE TIME + -- OF THE NO-WAIT CALL). + + END; + + BEGIN + START_TIME := CLOCK; + SELECT + T.DO_IT_NOW_OR_WAIT; + OR + -- THIS BRANCH MUST BE CHOSEN. + DELAY WAIT_TIME; + IF CLOCK >= (WAIT_TIME + START_TIME) THEN + NULL; + ELSE + FAILED ( "INSUFFICIENT WAITING TIME" ); + END IF; + OR_BRANCH_TAKEN := TRUE; + COMMENT( "OR_BRANCH TAKEN" ); + END SELECT; + + T.KEEP_ALIVE; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ( "TASKING ERROR RAISED" ); + + END; -- END OF BLOCK CONTAINING THE ENTRY CALL. + + -- BY NOW, THE TASK IS TERMINATED. + + IF OR_BRANCH_TAKEN THEN + NULL; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED?" ); + END IF; + + RESULT; + +END C97301D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97301e.ada b/gcc/testsuite/ada/acats/tests/c9/c97301e.ada new file mode 100644 index 000000000..39bf159de --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97301e.ada @@ -0,0 +1,118 @@ +-- C97301E.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT LEAST THE SPECIFIED +-- AMOUNT OF TIME IF A RENDEZVOUS IS NOT POSSIBLE. + +-- CASE E: THE BODY OF THE TASK CONTAINING THE CALLED ENTRY +-- DOES NOT CONTAIN AN ACCEPT_STATEMENT FOR THAT ENTRY - +-- (THE ENTRY BELONGS TO AN ENTRY FAMILY; SOME FAMILY MEMBERS +-- ARE "ACCEPTABLE", BUT NOT THE CALLED ONE.) + +-- RJW 3/31/86 + +with Impdef; +WITH REPORT; USE REPORT; +WITH CALENDAR; USE CALENDAR; +PROCEDURE C97301E IS + + OR_BRANCH_TAKEN : BOOLEAN := FALSE; + +BEGIN + + TEST ("C97301E", "CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT " & + "LEAST THE SPECIFIED AMOUNT OF TIME " & + "IN THE ABSENCE OF A CORRESPONDING " & + "ACCEPT_STATEMENT " ); + + DECLARE + + WAIT_TIME : DURATION := 3.0 * Impdef.One_Second; + + START_TIME : TIME; + + STOP_TIME : TIME; + + SUBTYPE SHORT IS INTEGER RANGE 10..20 ; + + KEEP_ALIVE : INTEGER := 15 ; + + TASK T IS + ENTRY DO_IT_NOW_OR_WAIT ( SHORT ) ; + END T ; + + TASK BODY T IS + BEGIN + + -- NO ACCEPT_STATEMENT FOR THE ENTRY_CALL BEING TESTED. + ACCEPT DO_IT_NOW_OR_WAIT ( IDENT_INT(15) ); + + -- THIS ALSO PREVENTS THIS SERVER + -- TASK FROM TERMINATING IF + -- UPON ACTIVATION + -- IT GETS TO RUN + -- AHEAD OF THE CALLER (WHICH + -- WOULD LEAD TO A SUBSEQUENT + -- TASKING_ERROR AT THE TIME + -- OF THE NO-WAIT CALL). + + END ; + + + BEGIN + START_TIME := CLOCK; + SELECT + T.DO_IT_NOW_OR_WAIT (10) ; -- ACCEPT_STATEMENT HAS 15. + OR + -- THEREFORE THIS BRANCH MUST BE CHOSEN. + DELAY WAIT_TIME; + STOP_TIME := CLOCK; + IF STOP_TIME >= (WAIT_TIME + START_TIME) THEN + NULL; + ELSE + FAILED ( "INSUFFICIENT DELAY" ); + END IF; + OR_BRANCH_TAKEN := TRUE ; + COMMENT( "OR_BRANCH TAKEN" ); + END SELECT; + + T.DO_IT_NOW_OR_WAIT (KEEP_ALIVE) ; + + EXCEPTION + WHEN TASKING_ERROR => + FAILED ( "TASKING ERROR" ); + + END; -- END OF BLOCK CONTAINING THE TIMED ENTRY CALL. + + -- BY NOW, TASK T IS TERMINATED. + + IF OR_BRANCH_TAKEN THEN + NULL ; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED" ); + END IF; + + RESULT; + +END C97301E ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97302a.ada b/gcc/testsuite/ada/acats/tests/c9/c97302a.ada new file mode 100644 index 000000000..18c7afbd3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97302a.ada @@ -0,0 +1,116 @@ +-- C97302A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT WHENEVER AN INDEX IS PRESENT IN A TIMED_ENTRY_CALL, IT +-- IS EVALUATED BEFORE ANY PARAMETER ASSOCIATIONS ARE EVALUATED, AND +-- PARAMETER ASSOCIATIONS ARE EVALUATED BEFORE THE DELAY EXPRESSION. +-- THEN A RENDEZVOUS IS ATTEMPTED. + +-- RJW 3/31/86 + +with Impdef; +WITH REPORT; USE REPORT; +WITH CALENDAR; USE CALENDAR; +PROCEDURE C97302A IS + + INDEX_COMPUTED : BOOLEAN := FALSE; + PARAM_COMPUTED : BOOLEAN := FALSE; + DELAY_COMPUTED : BOOLEAN := FALSE; +BEGIN + + TEST ("C97302A", "CHECK THAT WHENEVER AN INDEX IS PRESENT IN " & + "A TIMED_ENTRY_CALL, IT IS EVALUATED BEFORE " & + "ANY PARAMETER ASSOCIATIONS ARE EVALUATED, " & + "AND PARAMETER ASSOCIATIONS ARE EVALUATED " & + "BEFORE THE DELAY EXPRESSION" ); + DECLARE + + WAIT_TIME : DURATION := 3.0 * Impdef.One_Second; + + TYPE SHORT IS RANGE 10 .. 20; + + TASK T IS + ENTRY DO_IT_NOW_OR_WAIT + ( SHORT ) + ( DID_YOU_DO_IT : IN BOOLEAN ); + ENTRY KEEP_ALIVE; + END T; + + TASK BODY T IS + BEGIN + ACCEPT KEEP_ALIVE; + END T; + + FUNCTION F1 (X : SHORT) RETURN SHORT IS + BEGIN + INDEX_COMPUTED := TRUE; + RETURN (15); + END F1; + + FUNCTION F2 RETURN BOOLEAN IS + BEGIN + IF INDEX_COMPUTED THEN + NULL; + ELSE + FAILED ( "INDEX NOT EVALUATED FIRST" ); + END IF; + PARAM_COMPUTED := TRUE; + RETURN (FALSE); + END F2; + + FUNCTION F3 RETURN DURATION IS + BEGIN + IF PARAM_COMPUTED THEN + NULL; + ELSE + FAILED ( "PARAMETERS NOT EVALUATED BEFORE DELAY " & + "EXPRESSION" ); + END IF; + DELAY_COMPUTED := TRUE; + RETURN (WAIT_TIME); + END; + BEGIN + + SELECT + T.DO_IT_NOW_OR_WAIT + ( F1 (15) ) + ( NOT F2 ); + FAILED ("RENDEZVOUS OCCURRED"); + OR + DELAY F3; + END SELECT; + + T.KEEP_ALIVE; + + END; -- END OF BLOCK CONTAINING THE ENTRY CALLS. + + IF DELAY_COMPUTED THEN + NULL; + ELSE + FAILED( "DELAY EXPRESSION NOT EVALUATED" ); + END IF; + + RESULT; + +END C97302A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97303a.ada b/gcc/testsuite/ada/acats/tests/c9/c97303a.ada new file mode 100644 index 000000000..67504fcf5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97303a.ada @@ -0,0 +1,128 @@ +-- C97303A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TIMED_ENTRY_CALL CAN APPEAR IN PLACES WHERE A +-- SELECTIVE_WAIT CANNOT. + +-- PART 1: PACKAGE BODY EMBEDDED IN TASK BODY. + + +-- RM 4/06/1982 + +with Impdef; +WITH REPORT; +USE REPORT; +PROCEDURE C97303A IS + + +BEGIN + + + TEST ( "C97303A" , "CHECK THAT A TIMED_ENTRY_CALL CAN" & + " APPEAR WHERE A SELECTIVE_WAIT CANNOT" ); + + + ------------------------------------------------------------------- + + + DECLARE + + + TASK TT IS + ENTRY A ( AUTHORIZED : IN BOOLEAN ); + END TT ; + + + TASK BODY TT IS + + PACKAGE WITHIN_TASK_BODY IS + -- NOTHING HERE + END WITHIN_TASK_BODY ; + + + PACKAGE BODY WITHIN_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + A ( FALSE ) ; -- CALLING (OWN) ENTRY + OR + DELAY 1.0 * Impdef.One_Second; + COMMENT( "ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END WITHIN_TASK_BODY ; + + + BEGIN + + ACCEPT A ( AUTHORIZED : IN BOOLEAN ) DO + + IF AUTHORIZED THEN + COMMENT( "AUTHORIZED ENTRY_CALL" ); + ELSE + FAILED( "UNAUTHORIZED ENTRY_CALL" ); + END IF; + + END A ; + + END TT ; + + + PACKAGE OUTSIDE_TASK_BODY IS + -- NOTHING HERE + END OUTSIDE_TASK_BODY ; + + + PACKAGE BODY OUTSIDE_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + TT.A ( FALSE ) ; -- UNBORN + OR + DELAY 2.0 * Impdef.One_Second; + COMMENT( "(OUT:) ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END OUTSIDE_TASK_BODY ; + + + BEGIN + + TT.A ( TRUE ); + + EXCEPTION + + WHEN TASKING_ERROR => + FAILED( "TASKING ERROR" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + +END C97303A ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97303b.ada b/gcc/testsuite/ada/acats/tests/c9/c97303b.ada new file mode 100644 index 000000000..5043fa1db --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97303b.ada @@ -0,0 +1,133 @@ +-- C97303B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TIMED_ENTRY_CALL CAN APPEAR IN PLACES WHERE A +-- SELECTIVE_WAIT CANNOT. + +-- PART 2: PROCEDURE BODY EMBEDDED IN TASK BODY. + + +-- RM 4/12/1982 + +with Impdef; +WITH REPORT; +USE REPORT; +PROCEDURE C97303B IS + + +BEGIN + + + TEST ( "C97303B" , "CHECK THAT A TIMED_ENTRY_CALL CAN" & + " APPEAR WHERE A SELECTIVE_WAIT CANNOT" ); + + + ------------------------------------------------------------------- + + + DECLARE + + + TASK TT IS + ENTRY A ( AUTHORIZED : IN BOOLEAN ); + END TT ; + + + TASK BODY TT IS + + + PROCEDURE WITHIN_TASK_BODY ; + + + PROCEDURE WITHIN_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + A ( FALSE ) ; -- CALLING (OWN) ENTRY + OR + DELAY 1.0 * Impdef.One_Second; + COMMENT( "ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END WITHIN_TASK_BODY ; + + + BEGIN + + + -- CALL THE INNER PROC. TO FORCE EXEC. OF TIMED_E_CALL + WITHIN_TASK_BODY ; + + + ACCEPT A ( AUTHORIZED : IN BOOLEAN ) DO + + IF AUTHORIZED THEN + COMMENT( "AUTHORIZED ENTRY_CALL" ); + ELSE + FAILED( "UNAUTHORIZED ENTRY_CALL" ); + END IF; + + END A ; + + END TT ; + + + PROCEDURE OUTSIDE_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + TT.A ( FALSE ) ; -- UNBORN + OR + DELAY 1.0 * Impdef.One_Second; + COMMENT( "(OUT:) ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END OUTSIDE_TASK_BODY ; + + + PACKAGE CREATE_OPPORTUNITY_TO_CALL IS END; + PACKAGE BODY CREATE_OPPORTUNITY_TO_CALL IS + BEGIN + -- CALL THE OTHER PROC. TO FORCE EXEC. OF TIMED_E_CALL + OUTSIDE_TASK_BODY ; + END CREATE_OPPORTUNITY_TO_CALL ; + + + BEGIN + + TT.A ( TRUE ); + + EXCEPTION + + WHEN TASKING_ERROR => + FAILED( "TASKING ERROR" ); + + END ; + + ------------------------------------------------------------------- + + RESULT ; + + +END C97303B ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97303c.ada b/gcc/testsuite/ada/acats/tests/c9/c97303c.ada new file mode 100644 index 000000000..a6143037c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97303c.ada @@ -0,0 +1,128 @@ +-- C97303C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TIMED ENTRY CALL CAN APPEAR IN PLACES WHERE A SELECTIVE +-- WAIT IS NOT ALLOWED. + +-- PART 3: TASK BODY NESTED WITHIN A TASK. + +-- WRG 7/15/86 + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C97303C IS + +BEGIN + + TEST ("C97303C", "CHECK THAT A TIMED ENTRY CALL CAN " & + "APPEAR IN PLACES WHERE A SELECTIVE WAIT " & + "IS NOT ALLOWED; CASE: TASK BODY NESTED " & + "WITHIN A TASK"); + + DECLARE + + TASK T IS + ENTRY E; + ENTRY SYNCH; + END T; + + TASK BODY T IS + BEGIN + ACCEPT SYNCH; + ACCEPT SYNCH; + ACCEPT SYNCH; + ACCEPT E; + END T; + + TASK OUTER IS + ENTRY E; + ENTRY SYNCH; + END OUTER; + + TASK BODY OUTER IS + + TASK TYPE INNER; + + INNER1 : INNER; + + TASK BODY INNER IS + BEGIN + SELECT + T.E; + FAILED ("TIMED ENTRY CALL ACCEPTED - " & + "INNER (1)"); + OR + DELAY 1.0 * Impdef.One_Second; + T.SYNCH; + END SELECT; + + SELECT + OUTER.E; + FAILED ("TIMED ENTRY CALL ACCEPTED - " & + "INNER (2)"); + OR + DELAY 1.0 * Impdef.One_Second; + OUTER.SYNCH; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - INNER"); + END INNER; + + PACKAGE DUMMY IS + TYPE ACC_INNER IS ACCESS INNER; + INNER2 : ACC_INNER := NEW INNER; + END DUMMY; + + BEGIN + + SELECT + T.E; + FAILED ("TIMED ENTRY CALL ACCEPTED - OUTER"); + OR + DELAY 1.0 * Impdef.One_Second; + T.SYNCH; + END SELECT; + + ACCEPT SYNCH; + ACCEPT SYNCH; + ACCEPT E; + + EXCEPTION + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - OUTER"); + + END OUTER; + + BEGIN + + T.E; + OUTER.E; + + END; + + RESULT; + +END C97303C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97304a.ada b/gcc/testsuite/ada/acats/tests/c9/c97304a.ada new file mode 100644 index 000000000..8e4504730 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97304a.ada @@ -0,0 +1,123 @@ +-- C97304A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT THE EXCEPTION TASKING_ERROR WILL BE RAISED IF THE CALLED +-- TASK HAS ALREADY COMPLETED ITS EXECUTION AT THE TIME OF THE +-- TIMED_ENTRY_CALL. + + +-- RM 5/28/82 +-- SPS 11/21/82 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C97304A IS + + -- THE TASK WILL HAVE HIGHER PRIORITY ( PRIORITY'LAST ) + +BEGIN + + + ------------------------------------------------------------------- + + + TEST ("C97304A", "CHECK THAT THE EXCEPTION TASKING_ERROR WILL" & + " BE RAISED IF THE CALLED TASK HAS ALREADY" & + " COMPLETED ITS EXECUTION AT THE TIME OF THE" & + " TIMED_ENTRY_CALL" ); + + + DECLARE + + + TASK TYPE T_TYPE IS + + + ENTRY E ; + + END T_TYPE ; + + + T_OBJECT1 : T_TYPE ; + + + TASK BODY T_TYPE IS + BUSY : BOOLEAN := FALSE ; + BEGIN + + NULL; + + END T_TYPE ; + + + BEGIN + + + FOR I IN 1..5 LOOP + EXIT WHEN T_OBJECT1'TERMINATED ; + DELAY 10.0 * Impdef.One_Second; + END LOOP; + + + IF NOT T_OBJECT1'TERMINATED THEN + COMMENT( "TASK NOT YET TERMINATED (AFTER 50 S.)" ); + END IF; + + + BEGIN + + SELECT + T_OBJECT1.E ; + FAILED( "CALL WAS NOT DISOBEYED" ); + OR + DELAY 1.0 * Impdef.One_Second; + FAILED( "'OR' BRANCH TAKEN INSTEAD OF TSKG_ERROR" ); + END SELECT; + + FAILED( "EXCEPTION NOT RAISED" ); + + EXCEPTION + + WHEN TASKING_ERROR => + NULL ; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED" ); + + END ; + + + END ; + + + ------------------------------------------------------------------- + + + + RESULT; + + +END C97304A ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97304b.ada b/gcc/testsuite/ada/acats/tests/c9/c97304b.ada new file mode 100644 index 000000000..1d7f4cd06 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97304b.ada @@ -0,0 +1,84 @@ +-- C97304B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT TASKING_ERROR IS RAISED IF THE CALLED TASK IS ABORTED +-- BEFORE THE TIMED ENTRY CALL IS EXECUTED. + +-- WRG 7/13/86 + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C97304B IS + +BEGIN + + TEST ("C97304B", "CHECK THAT TASKING_ERROR IS RAISED IF THE " & + "CALLED TASK IS ABORTED BEFORE THE TIMED " & + "ENTRY CALL IS EXECUTED"); + + DECLARE + + TASK T IS + ENTRY E (I : INTEGER); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (I : INTEGER); + FAILED ("ENTRY CALL ACCEPTED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END T; + + FUNCTION F RETURN INTEGER IS + BEGIN + ABORT T; + RETURN 1; + END F; + + BEGIN + + SELECT + T.E (F); + FAILED ("TIMED ENTRY CALL MADE"); + OR + DELAY 1.0 * Impdef.One_Second; + FAILED ("DELAY ALTERNATIVE TAKEN"); + END SELECT; + + FAILED ("EXCEPTION NOT RAISED"); + + EXCEPTION + + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + + END; + + RESULT; + +END C97304B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97305a.ada b/gcc/testsuite/ada/acats/tests/c9/c97305a.ada new file mode 100644 index 000000000..81349b87d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97305a.ada @@ -0,0 +1,100 @@ +-- C97305A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY POSSIBLE (FOR A +-- TIMED ENTRY CALL), IT IS PERFORMED. + +-- CASE A: SINGLE ENTRY; THE CALLED TASK IS EXECUTING AN ACCEPT +-- STATEMENT. + +-- WRG 7/13/86 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C97305A IS + + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE; + STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE; + COUNT : POSITIVE := 1; + ZERO : DURATION := 1.0; + + +BEGIN + + TEST ("C97305A", "CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY " & + "POSSIBLE (FOR A TIMED ENTRY CALL), IT " & + "IS PERFORMED"); + + IF EQUAL (3, 3) THEN + ZERO := 0.0; + END IF; + + DECLARE + + TASK T IS + ENTRY E (B : IN OUT BOOLEAN); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (B : IN OUT BOOLEAN) DO + B := IDENT_BOOL (TRUE); + END E; + END T; + + BEGIN + + WHILE NOT STATEMENTS_AFTER_CALL_EXECUTED LOOP + DELAY 1.0 * Impdef.One_Second; + + SELECT + T.E (RENDEZVOUS_OCCURRED); + STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE); + OR + DELAY ZERO; + IF COUNT < 60 * 60 THEN + COUNT := COUNT + 1; + ELSE + FAILED ("NO RENDEZVOUS AFTER AT LEAST ONE " & + "HOUR ELAPSED"); + EXIT; + END IF; + END SELECT; + END LOOP; + + END; + + IF NOT RENDEZVOUS_OCCURRED THEN + FAILED ("RENDEZVOUS DID NOT OCCUR"); + END IF; + + IF COUNT > 1 THEN + COMMENT ("DELAYED" & POSITIVE'IMAGE(COUNT) & " SECONDS"); + END IF; + + RESULT; + +END C97305A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97305b.ada b/gcc/testsuite/ada/acats/tests/c9/c97305b.ada new file mode 100644 index 000000000..13a28a39e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97305b.ada @@ -0,0 +1,104 @@ +-- C97305B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY POSSIBLE (FOR A +-- TIMED ENTRY CALL), IT IS PERFORMED. + +-- CASE B: ENTRY FAMILY; THE CALLED TASK IS EXECUTING A SELECTIVE WAIT. + +-- WRG 7/13/86 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C97305B IS + + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE; + STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE; + COUNT : POSITIVE := 1; + ZERO : DURATION := 1.0; + + +BEGIN + + TEST ("C97305B", "CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY " & + "POSSIBLE (FOR A TIMED ENTRY CALL), IT " & + "IS PERFORMED"); + + IF EQUAL (3, 3) THEN + ZERO := 0.0; + END IF; + + DECLARE + + TASK T IS + ENTRY E (1..3) (B : IN OUT BOOLEAN); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E (2) (B : IN OUT BOOLEAN) DO + B := IDENT_BOOL (TRUE); + END E; + OR + ACCEPT E (3) (B : IN OUT BOOLEAN); + FAILED ("NONEXISTENT ENTRY CALL ACCEPTED"); + END SELECT; + END T; + + BEGIN + + WHILE NOT STATEMENTS_AFTER_CALL_EXECUTED LOOP + DELAY 1.0 * Impdef.One_Second; + + SELECT + T.E (2) (RENDEZVOUS_OCCURRED); + STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE); + OR + DELAY ZERO; + IF COUNT < 60 * 60 THEN + COUNT := COUNT + 1; + ELSE + FAILED ("NO RENDEZVOUS AFTER AT LEAST ONE " & + "HOUR ELAPSED"); + EXIT; + END IF; + END SELECT; + END LOOP; + + END; + + IF NOT RENDEZVOUS_OCCURRED THEN + FAILED ("RENDEZVOUS DID NOT OCCUR"); + END IF; + + IF COUNT > 1 THEN + COMMENT ("DELAYED" & POSITIVE'IMAGE(COUNT) & " SECONDS"); + END IF; + + RESULT; + +END C97305B; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97305c.ada b/gcc/testsuite/ada/acats/tests/c9/c97305c.ada new file mode 100644 index 000000000..ee9953ba4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97305c.ada @@ -0,0 +1,90 @@ +-- C97305C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF THE RENDEZVOUS IS NOT IMMEDIATELY POSSIBLE BUT BECOMES +-- POSSIBLE BEFORE THE DELAY EXPIRES, THE TIMED ENTRY CALL IS ACCEPTED. + +-- CASE A: SINGLE ENTRY; THE CALLED TASK IS EXECUTING AN ACCEPT +-- STATEMENT. + +-- WRG 7/13/86 +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C97305C IS + + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE; + STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE; + DELAY_IN_MINUTES : CONSTANT POSITIVE := 30; + + +BEGIN + + TEST ("C97305C", "CHECK THAT IF THE RENDEZVOUS IS NOT " & + "IMMEDIATELY POSSIBLE BUT BECOMES POSSIBLE " & + "BEFORE THE DELAY EXPIRES, THE TIMED ENTRY " & + "CALL IS ACCEPTED"); + + DECLARE + + TASK T IS + ENTRY E (B : IN OUT BOOLEAN); + END T; + + TASK BODY T IS + BEGIN + DELAY 10.0 * Impdef.One_Long_Second; + ACCEPT E (B : IN OUT BOOLEAN) DO + B := IDENT_BOOL (TRUE); + END E; + END T; + + BEGIN + + SELECT + T.E (RENDEZVOUS_OCCURRED); + STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE); + OR + DELAY DELAY_IN_MINUTES * 60.0 * Impdef.One_Long_Second; + FAILED ("TIMED ENTRY CALL NOT ACCEPTED AFTER" & + POSITIVE'IMAGE(DELAY_IN_MINUTES) & + " MINUTES ELAPSED"); + + END SELECT; + + END; + + IF NOT RENDEZVOUS_OCCURRED THEN + FAILED ("RENDEZVOUS DID NOT OCCUR"); + END IF; + + IF NOT STATEMENTS_AFTER_CALL_EXECUTED THEN + FAILED ("STATEMENTS AFTER ENTRY CALL NOT EXECUTED"); + END IF; + + RESULT; + +END C97305C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97305d.ada b/gcc/testsuite/ada/acats/tests/c9/c97305d.ada new file mode 100644 index 000000000..022b0adcb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97305d.ada @@ -0,0 +1,95 @@ +-- C97305D.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF THE RENDEZVOUS IS NOT IMMEDIATELY POSSIBLE BUT BECOMES +-- POSSIBLE BEFORE THE DELAY EXPIRES, THE TIMED ENTRY CALL IS ACCEPTED. + +-- CASE B: ENTRY FAMILY; THE CALLED TASK IS EXECUTING A SELECTIVE WAIT. + +-- WRG 7/13/86 +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C97305D IS + + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE; + STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE; + DELAY_IN_MINUTES : CONSTANT POSITIVE := 30; + + +BEGIN + + TEST ("C97305D", "CHECK THAT IF THE RENDEZVOUS IS NOT " & + "IMMEDIATELY POSSIBLE BUT BECOMES POSSIBLE " & + "BEFORE THE DELAY EXPIRES, THE TIMED ENTRY " & + "CALL IS ACCEPTED"); + + DECLARE + + TASK T IS + ENTRY E (1..3) (B : IN OUT BOOLEAN); + END T; + + TASK BODY T IS + BEGIN + DELAY 10.0 * Impdef.One_Second; + + SELECT + ACCEPT E (2) (B : IN OUT BOOLEAN) DO + B := IDENT_BOOL (TRUE); + END E; + OR + ACCEPT E (3) (B : IN OUT BOOLEAN); + FAILED ("NONEXISTENT ENTRY CALL ACCEPTED"); + END SELECT; + END T; + + BEGIN + + SELECT + T.E (2) (RENDEZVOUS_OCCURRED); + STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE); + OR + DELAY DELAY_IN_MINUTES * 60.0 * Impdef.One_Second; + FAILED ("TIMED ENTRY CALL NOT ACCEPTED AFTER" & + POSITIVE'IMAGE(DELAY_IN_MINUTES) & + " MINUTES ELAPSED"); + + END SELECT; + + END; + + IF NOT RENDEZVOUS_OCCURRED THEN + FAILED ("RENDEZVOUS DID NOT OCCUR"); + END IF; + + IF NOT STATEMENTS_AFTER_CALL_EXECUTED THEN + FAILED ("STATEMENTS AFTER ENTRY CALL NOT EXECUTED"); + END IF; + + RESULT; + +END C97305D; diff --git a/gcc/testsuite/ada/acats/tests/c9/c97307a.ada b/gcc/testsuite/ada/acats/tests/c9/c97307a.ada new file mode 100644 index 000000000..32d26e6b3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c97307a.ada @@ -0,0 +1,209 @@ +-- C97307A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TIMED ENTRY CALL THAT IS CANCELED (BECAUSE THE DELAY HAS +-- EXPIRED) IS REMOVED FROM THE QUEUE OF THE CALLED TASK'S ENTRY. + +-- WRG 7/14/86 + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C97307A IS + +BEGIN + + TEST ("C97307A", "CHECK THAT A TIMED ENTRY CALL THAT IS " & + "CANCELED (BECAUSE THE DELAY HAS EXPIRED) IS " & + "REMOVED FROM THE QUEUE OF THE CALLED TASK'S " & + "ENTRY"); + + DECLARE + + DELAY_TIME : CONSTANT DURATION := 2 * 60.0 * Impdef.One_Second; + + TASK EXPIRED IS + ENTRY INCREMENT; + ENTRY READ (COUNT : OUT NATURAL); + END EXPIRED; + + TASK TYPE NON_TIMED_CALLER IS + ENTRY NAME (N : NATURAL); + END NON_TIMED_CALLER; + + TASK TYPE TIMED_CALLER IS + ENTRY NAME (N : NATURAL); + END TIMED_CALLER; + + CALLER1 : TIMED_CALLER; + CALLER2 : NON_TIMED_CALLER; + CALLER3 : TIMED_CALLER; + CALLER4 : NON_TIMED_CALLER; + CALLER5 : TIMED_CALLER; + + TASK T IS + ENTRY E (NAME : NATURAL); + END T; + + TASK DISPATCH IS + ENTRY READY; + END DISPATCH; + + -------------------------------------------------- + + TASK BODY EXPIRED IS + EXPIRED_CALLS : NATURAL := 0; + BEGIN + LOOP + SELECT + ACCEPT INCREMENT DO + EXPIRED_CALLS := EXPIRED_CALLS + 1; + END INCREMENT; + OR + ACCEPT READ (COUNT : OUT NATURAL) DO + COUNT := EXPIRED_CALLS; + END READ; + OR + TERMINATE; + END SELECT; + END LOOP; + END EXPIRED; + + -------------------------------------------------- + + TASK BODY NON_TIMED_CALLER IS + MY_NAME : NATURAL; + BEGIN + ACCEPT NAME (N : NATURAL) DO + MY_NAME := N; + END NAME; + + T.E (MY_NAME); + END NON_TIMED_CALLER; + + -------------------------------------------------- + + TASK BODY TIMED_CALLER IS + MY_NAME : NATURAL; + BEGIN + ACCEPT NAME (N : NATURAL) DO + MY_NAME := N; + END NAME; + + SELECT + T.E (MY_NAME); + FAILED ("TIMED ENTRY CALL NOT CANCELED FOR CALLER" & + NATURAL'IMAGE(MY_NAME)); + OR + DELAY DELAY_TIME; + EXPIRED.INCREMENT; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TIMED_CALLER -- " & + "CALLER" & NATURAL'IMAGE(MY_NAME)); + END TIMED_CALLER; + + -------------------------------------------------- + + TASK BODY DISPATCH IS + BEGIN + CALLER1.NAME (1); + ACCEPT READY; + + CALLER2.NAME (2); + ACCEPT READY; + + CALLER3.NAME (3); + ACCEPT READY; + + CALLER4.NAME (4); + ACCEPT READY; + + CALLER5.NAME (5); + END DISPATCH; + + -------------------------------------------------- + + TASK BODY T IS + + DESIRED_QUEUE_LENGTH : NATURAL := 1; + EXPIRED_CALLS : NATURAL; + + ACCEPTED : ARRAY (1..5) OF NATURAL RANGE 0..5 + := (OTHERS => 0); + ACCEPTED_INDEX : NATURAL := 0; + + BEGIN + LOOP + LOOP + EXPIRED.READ (EXPIRED_CALLS); + EXIT WHEN E'COUNT >= DESIRED_QUEUE_LENGTH - + EXPIRED_CALLS; + DELAY 2.0 * Impdef.One_Long_Second; + END LOOP; + EXIT WHEN DESIRED_QUEUE_LENGTH = 5; + DISPATCH.READY; + DESIRED_QUEUE_LENGTH := DESIRED_QUEUE_LENGTH + 1; + END LOOP; + + -- AT THIS POINT, FIVE TASKS WERE QUEUED. + -- LET THE TIMED ENTRY CALLS ISSUED BY CALLER1, + -- CALLER3, AND CALLER5 EXPIRE: + + DELAY DELAY_TIME + 10.0 * Impdef.One_Long_Second; + + -- AT THIS POINT, ALL THE TIMED ENTRY CALLS MUST HAVE + -- EXPIRED AND BEEN REMOVED FROM THE ENTRY QUEUE FOR E, + -- OTHERWISE THE IMPLEMENTATION HAS FAILED THIS TEST. + + WHILE E'COUNT > 0 LOOP + ACCEPT E (NAME : NATURAL) DO + ACCEPTED_INDEX := ACCEPTED_INDEX + 1; + ACCEPTED (ACCEPTED_INDEX) := NAME; + END E; + END LOOP; + + IF ACCEPTED /= (2, 4, 0, 0, 0) THEN + FAILED ("SOME TIMED CALLS NOT REMOVED FROM ENTRY " & + "QUEUE"); + COMMENT ("ORDER ACCEPTED WAS:" & + NATURAL'IMAGE (ACCEPTED (1)) & ',' & + NATURAL'IMAGE (ACCEPTED (2)) & ',' & + NATURAL'IMAGE (ACCEPTED (3)) & ',' & + NATURAL'IMAGE (ACCEPTED (4)) & ',' & + NATURAL'IMAGE (ACCEPTED (5)) ); + END IF; + END T; + + -------------------------------------------------- + + BEGIN + + NULL; + + END; + + RESULT; + +END C97307A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974001.a b/gcc/testsuite/ada/acats/tests/c9/c974001.a new file mode 100644 index 000000000..04ac93e6d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974001.a @@ -0,0 +1,152 @@ +-- C974001.A +-- +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the abortable part of an asynchronous select statement +-- is aborted if it does not complete before the triggering statement +-- completes, where the triggering statement is a delay_relative +-- statement and check that the sequence of statements of the triggering +-- alternative is executed after the abortable part is left. +-- +-- TEST DESCRIPTION: +-- Declare a task with an accept statement containing an asynchronous +-- select with a delay_relative triggering statement. Parameterize +-- the accept statement with the time to be used in the delay. Simulate a +-- time-consuming calculation by declaring a procedure containing an +-- infinite loop. Call this procedure in the abortable part. +-- +-- The delay will expire before the abortable part completes, at which +-- time the abortable part is aborted, and the sequence of statements +-- following the triggering statement is executed. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with Report; +with ImpDef; + +procedure C974001 is + + + --========================================================-- + + -- Medium length delay + Allotted_Time : constant Duration := ImpDef.Switch_To_New_Task; + + Calculation_Canceled : exception; + + + Count : Integer := 1234; + + procedure Lengthy_Calculation is + begin + -- Simulate a non-converging calculation. + loop -- Infinite loop. + Count := (Count + 1) mod 10; + delay ImpDef.Minimum_Task_Switch; -- allow other task + end loop; + end Lengthy_Calculation; + + + --========================================================-- + + + task type Timed_Calculation is + entry Calculation (Time_Limit : in Duration); + end Timed_Calculation; + + + task body Timed_Calculation is + -- + begin + loop + select + accept Calculation (Time_Limit : in Duration) do + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + delay Time_Limit; -- Time_Limit is not up yet, so + -- Lengthy_Calculation starts. + + raise Calculation_Canceled; -- This is executed after + -- Lengthy_Calculation aborted. + then abort + Lengthy_Calculation; -- Delay expires before complete, + -- so this call is aborted. + + -- Check that the whole of the abortable part is aborted, + -- not just the statement in the abortable part that was + -- executing at the time + Report.Failed ("Abortable part not aborted"); + + end select; + + Report.Failed ("Triggering alternative sequence of " & + "statements not executed"); + + exception -- New Ada 9x: handler within accept + when Calculation_Canceled => + if Count = 1234 then + Report.Failed ("Abortable part did not execute"); + end if; + end Calculation; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Timed_Calculation task"); + end Timed_Calculation; + + + --========================================================-- + + +begin -- Main program. + + Report.Test ("C974001", "Asynchronous Select: Trigger is delay_relative" & + " which completes before abortable part"); + + declare + Timed : Timed_Calculation; -- Task. + begin + Timed.Calculation (Time_Limit => Allotted_Time); -- Asynchronous select + -- inside accept block. + exception + when Calculation_Canceled => + null; -- expected behavior + end; + + Report.Result; + +end C974001; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974002.a b/gcc/testsuite/ada/acats/tests/c9/c974002.a new file mode 100644 index 000000000..1138e8da3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974002.a @@ -0,0 +1,209 @@ +-- C974002.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the sequence of statements of the triggering alternative +-- of an asynchronous select statement is executed if the triggering +-- statement is a delay_until statement, and the specified time has +-- already passed. Check that the abortable part is not executed after +-- the sequence of statements of the triggering alternative is left. +-- +-- Check that the sequence of statements of the triggering alternative +-- of an asynchronous select statement is not executed if the abortable +-- part completes before the triggering statement, and the triggering +-- statement is a delay_until statement. +-- +-- TEST DESCRIPTION: +-- Declare a task with an accept statement containing an asynchronous +-- select with a delay_until triggering statement. Parameterize +-- the accept statement with the time to be used in the delay. Simulate +-- a quick calculation by declaring a procedure which sets a Boolean +-- flag. Call this procedure in the abortable part. +-- +-- Make two calls to the task entry: (1) with a time that has already +-- expired, and (2) with a time that will not expire before the quick +-- calculation completes. +-- +-- For (1), the sequence of statements following the triggering statement +-- is executed, and the abortable part never starts. +-- +-- For (2), the abortable part completes before the triggering statement, +-- the delay is canceled, and the sequence of statements following the +-- triggering statement never starts. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 26 Nov 95 SAIC Bug fix for ACVC 2.0.1. +-- +--! + +with Report; +with Ada.Calendar; +with ImpDef; +procedure C974002 is + + function "-" (Left: Ada.Calendar.Time; Right: Duration ) + return Ada.Calendar.Time renames Ada.Calendar."-"; + function "+" (Left: Ada.Calendar.Time; Right: Duration ) + return Ada.Calendar.Time renames Ada.Calendar."+"; + + Abortable_Part_Executed : Boolean; + Triggering_Alternative_Executed : Boolean; + + + --========================================================-- + + + procedure Quick_Calculation is + begin + if Report.Equal (1, 1) then + Abortable_Part_Executed := True; + end if; + end Quick_Calculation; + + + --========================================================-- + + + task type Timed_Calculation_Task is + entry Calculation (Time_Out : in Ada.Calendar.Time); + end Timed_Calculation_Task; + + + task body Timed_Calculation_Task is + begin + loop + select + accept Calculation (Time_Out : in Ada.Calendar.Time) do + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + delay until Time_Out; -- Triggering + -- statement. + + Triggering_Alternative_Executed := True; -- Triggering + -- alternative. + then abort + Quick_Calculation; -- Abortable part. + end select; + end Calculation; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Timed_Calculation_Task"); + end Timed_Calculation_Task; + + + --========================================================-- + + + Start_Time : constant Ada.Calendar.Time := + Ada.Calendar.Time_of (1901,1,1); + Minute : constant Duration := 60.0; + + + --========================================================-- + + +begin -- Main program. + + Report.Test ("C974002", "Asynchronous Select with Delay_Until"); + + -- take care of implementations that start the clock at 1/1/01 + delay ImpDef.Delay_For_Time_Past; + + + Abortable_Part_Executed := False; + Triggering_Alternative_Executed := False; + + NO_DELAY_SUBTEST: + + declare + -- Set Expiry to a time which has already passed + Expiry : constant Ada.Calendar.Time := Start_Time; + Timed : Timed_Calculation_Task; + begin + + -- Expiry is the time to be specified in the delay_until statement + -- of the asynchronous select. Since it has already passed, the + -- abortable part should not execute, and the sequence of statements + -- of the triggering alternative should be executed. + + Timed.Calculation (Time_Out => Expiry); -- Asynchronous select + -- inside accept block. + if Abortable_Part_Executed then + Report.Failed ("No delay: Abortable part was executed"); + end if; + + if not Triggering_Alternative_Executed then + Report.Failed ("No delay: triggering alternative sequence " & + "of statements was not executed"); + end if; + end No_Delay_Subtest; + + + Abortable_Part_Executed := False; + Triggering_Alternative_Executed := False; + + LONG_DELAY_SUBTEST: + + declare + + -- Quick_Calculation should finish before expiry. + Expiry : constant Ada.Calendar.Time := + Ada.Calendar.Clock + Minute; + Timed : Timed_Calculation_Task; + + begin + + -- Expiry is the time to be specified in the delay_until statement + -- of the asynchronous select. It should not pass before the abortable + -- part completes, at which time control should return to the caller; + -- the sequence of statements of the triggering alternative should + -- not be executed. + + Timed.Calculation (Time_Out => Expiry); -- Asynchronous select. + + if not Abortable_Part_Executed then + Report.Failed ("Long delay: Abortable part was not executed"); + end if; + + if Triggering_Alternative_Executed then + Report.Failed ("Long delay: triggering alternative sequence " & + "of statements was executed"); + end if; + end Long_Delay_Subtest; + + + Report.Result; + +end C974002; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974003.a b/gcc/testsuite/ada/acats/tests/c9/c974003.a new file mode 100644 index 000000000..c353a918d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974003.a @@ -0,0 +1,249 @@ +-- C974003.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the abortable part of an asynchronous select statement +-- is aborted if it does not complete before the triggering statement +-- completes, where the triggering statement is a task entry call, and +-- the entry call is queued. +-- +-- Check that the sequence of statements of the triggering alternative +-- is executed after the abortable part is left. +-- +-- TEST DESCRIPTION: +-- Declare a main procedure containing an asynchronous select with a task +-- entry call as triggering statement. Force the entry call to be +-- queued by having the task call a procedure, prior to the corresponding +-- accept statement, which simulates a routine waiting for user input +-- (with a delay). +-- +-- Simulate a time-consuming routine in the abortable part by calling a +-- procedure containing an infinite loop. Meanwhile, simulate input by +-- the user (the delay expires), which causes the task to execute the +-- accept statement corresponding to the triggering entry call. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package C974003_0 is -- Automated teller machine abstraction. + + + -- Flags for testing purposes: + -- + TC_Triggering_Statement_Completed : Boolean := False; + TC_Count : Integer := 1234; -- Global to defeat + -- optimization. + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + + Transaction_Canceled : exception; + + + task type ATM_Keyboard_Task is + entry Cancel_Pressed; + end ATM_Keyboard_Task; + + + procedure Read_Card (Card : in out ATM_Card_Type); + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + +private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + +end C974003_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +package body C974003_0 is + + + procedure Listen_For_Input (Key : out Key_Enum) is + begin + -- Model the situation where the user waits a bit for the card to + -- be validated, then presses cancel before it completes. + + -- Delay long enough to force queuing of Keyboard.Cancel_Pressed. + delay ImpDef.Minimum_Task_Switch; + + if Report.Equal (3, 3) then -- Always true. + Key := Cancel; + end if; + end Listen_For_Input; + + + + -- One of these gets created as "Keyboard" for each transaction + -- + task body ATM_Keyboard_Task is + Key_Pressed : Key_Enum := None; + begin + loop + -- Force entry calls + Listen_For_Input (Key_Pressed); -- to be queued, + -- then set guard to + -- true. + select + when (Key_Pressed = Cancel) => -- Guard is now + accept Cancel_Pressed do -- true, so accept + TC_Triggering_Statement_Completed := True; -- queued entry + end Cancel_Pressed; -- call. + + -- User has cancelled the transaction so we exit the + -- loop and allow the task to terminate + exit; + else + Key_Pressed := None; + end select; + + end loop; + exception + when others => + Report.Failed ("Unexpected Exception in ATM_Keyboard_Task"); + end ATM_Keyboard_Task; + + + + procedure Read_Card (Card : in out ATM_Card_Type) is + begin + Card.Number := 9999; + Card.PIN := 111; + end Read_Card; + + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + -- Simulate an exceedingly long validation activity. + loop -- Infinite loop. + TC_Count := (TC_Count + 1) mod Integer (Card.PIN); + -- Synch. point to allow transfer of control to Keyboard + -- task during this simulation + delay ImpDef.Minimum_Task_Switch; + exit when not Report.Equal (TC_Count, TC_Count); -- Always false. + end loop; + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Report.Failed ("Triggering alternative sequence of statements " & + "not executed"); + if not TC_Triggering_Statement_Completed then + Report.Failed ("Triggering statement did not complete"); + end if; + if TC_Count = 1234 then + -- Initial value is unchanged + Report.Failed ("Abortable part did not execute"); + end if; + end Perform_Transaction; + + +end C974003_0; + + + --==================================================================-- + + +with Report; + +with C974003_0; -- Automated teller machine abstraction. +use C974003_0; + +procedure C974003 is + + Card_Data : ATM_Card_Type; + +begin -- Main program. + + Report.Test ("C974003", "Asynchronous Select: Trigger is queued on a " & + "task entry and completes first"); + + Read_Card (Card_Data); + + declare + -- Create the task for this transaction + Keyboard : C974003_0.ATM_Keyboard_Task; + begin + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + Keyboard.Cancel_Pressed; -- Entry call is initially queued, so + -- abortable part starts. + + raise Transaction_Canceled; -- This is executed after Validate_Card + -- is aborted. + then abort + Validate_Card (Card_Data); -- Keyboard.Cancel_Pressed is accepted + -- and completes before this call + -- finishes; it is then aborted. + + -- Check that the whole of the abortable part is aborted, not + -- just the statement in the abortable part that was executing + -- at the time + Report.Failed ("Abortable part not aborted"); + + end select; + + Perform_Transaction (Card_Data); -- Should not be reached. + exception + when Transaction_Canceled => + if not TC_Triggering_Statement_Completed then + Report.Failed ("Triggering alternative sequence of statements " & + "executed but triggering statement not complete"); + end if; + if TC_Count = 1234 then + -- Initial value is unchanged + Report.Failed ("Abortable part did not execute"); + end if; + end; + + Report.Result; + +end C974003; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974004.a b/gcc/testsuite/ada/acats/tests/c9/c974004.a new file mode 100644 index 000000000..b1200c103 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974004.a @@ -0,0 +1,273 @@ +-- C974004.A +-- +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the abortable part of an asynchronous select statement +-- is aborted if it does not complete before the triggering statement +-- completes, where the triggering statement is a task entry call, +-- the entry call is queued, and the entry call completes by propagating +-- an exception and that the sequence of statements of the triggering +-- alternative is not executed after the abortable part is left and that +-- the exception propagated by the entry call is re-raised immediately +-- following the asynchronous select. +-- +-- TEST DESCRIPTION: +-- Declare a main procedure containing an asynchronous select with a task +-- entry call as triggering statement. Force the entry call to be +-- queued by having the task call a procedure, prior to the corresponding +-- accept statement, which simulates a routine waiting for user input +-- (with a delay). +-- +-- Simulate a time-consuming routine in the abortable part by calling a +-- procedure containing an infinite loop. Meanwhile, simulate input by +-- the user (the delay expires), which causes the task to execute the +-- accept statement corresponding to the triggering entry call. Raise +-- an exception in the accept statement which is not handled by the task, +-- and which is thus propagated to the caller. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package C974004_0 is -- Automated teller machine abstraction. + + + -- Flags for testing purposes: + + Count : Integer := 1234; -- Global to defeat + -- optimization. + Propagated_From_Task : exception; + + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + + Transaction_Canceled : exception; + + + task type ATM_Keyboard_Task is + entry Cancel_Pressed; + end ATM_Keyboard_Task; + + + procedure Read_Card (Card : in out ATM_Card_Type); + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + +private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + +end C974004_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +package body C974004_0 is + + + procedure Listen_For_Input (Key : out Key_Enum) is + begin + -- Simulate the situation where a user waits a bit for the card to + -- be validated, then presses cancel before it completes. + + -- Delay long enough to force queuing of Keyboard.Cancel_Pressed. + delay ImpDef.Clear_Ready_Queue; + + if Report.Equal (3, 3) then -- Always true. + Key := Cancel; + end if; + end Listen_For_Input; + + + -- One of these gets created as "Keyboard" for each transaction + -- + task body ATM_Keyboard_Task is + Key_Pressed : Key_Enum := None; + begin + loop + -- Force entry calls to be + Listen_For_Input (Key_Pressed); -- queued, then set guard to + -- true. + select + when (Key_Pressed = Cancel) => -- Guard is now true, so accept + accept Cancel_Pressed do -- queued entry call. + null; --:::: user code for cancel + -- Now simulate an unexpected exception arising in the + -- user code + raise Propagated_From_Task; -- Propagate an exception. + + end Cancel_Pressed; + + Report.Failed + ("Exception not propagated in ATM_Keyboard_Task"); + + -- User has canceled the transaction so we exit the + -- loop and allow the task to terminate + exit; + else + Key_Pressed := None; + end select; + end loop; + exception + when Propagated_From_Task => + null; -- This is the expected test behavior + when others => + Report.Failed ("Unexpected Exception in ATM_Keyboard_Task"); + end ATM_Keyboard_Task; + + + + procedure Read_Card (Card : in out ATM_Card_Type) is + begin + Card.Number := 9999; + Card.PIN := 111; + end Read_Card; + + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + -- Simulate an exceedingly long validation activity. + loop -- Infinite loop. + Count := (Count + 1) mod Integer (Card.PIN); + -- Synch. point to allow transfer of control to Keyboard + -- task during this simulation + delay ImpDef.Minimum_Task_Switch; + exit when not Report.Equal (Count, Count); -- Always false. + end loop; + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Report.Failed ("Exception not re-raised immediately following " & + "asynchronous select"); + if Count = 1234 then + -- Initial value is unchanged + Report.Failed ("Abortable part did not execute"); + end if; + end Perform_Transaction; + + +end C974004_0; + + + --==================================================================-- + + +with Report; + +with C974004_0; -- Automated teller machine abstraction. +use C974004_0; + +procedure C974004 is + + Card_Data : ATM_Card_Type; + +begin -- Main program. + + Report.Test ("C974004", "Asynchronous Select: Trigger is queued on a " & + "task entry and is completed first by an " & + "exception"); + + Read_Card (Card_Data); + + begin + + declare + -- Create the task for this transaction + Keyboard : C974004_0.ATM_Keyboard_Task; + begin + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + Keyboard.Cancel_Pressed; -- Entry call initially queued, so + -- abortable part starts. + + raise Transaction_Canceled; -- Should not be executed. + then abort + Validate_Card (Card_Data); -- Keyboard.Cancel_Pressed is accepted + -- and propagates an exception before + -- this call finishes; it is then + -- aborted. + + -- Check that the whole of the abortable part is aborted, not + -- just the statement in the abortable part that was executing + -- at the time + Report.Failed ("Abortable part not aborted"); + end select; + -- The propagated exception is + -- re-raised here; control passes to + -- the exception handler. + + Perform_Transaction(Card_Data); -- Should not be reached. + exception + when Transaction_Canceled => + Report.Failed ("Triggering alternative sequence of statements " & + "executed"); + when Propagated_From_Task => + -- This is the expected test path + if Count = 1234 then + -- Initial value is unchanged + Report.Failed ("Abortable part did not execute"); + end if; + when Tasking_Error => + Report.Failed ("Tasking_Error raised"); + when others => + Report.Failed ("Wrong exception raised"); + end; + + exception + when Propagated_From_Task => + Report.Failed ("Correct exception raised at wrong level"); + when others => + Report.Failed ("Wrong exception raised at wrong level"); + end; + + Report.Result; + +end C974004; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974005.a b/gcc/testsuite/ada/acats/tests/c9/c974005.a new file mode 100644 index 000000000..196a8edc0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974005.a @@ -0,0 +1,259 @@ +-- C974005.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that Tasking_Error is raised at the point of an entry call +-- which is the triggering statement of an asynchronous select, if +-- the entry call is queued, but the task containing the entry completes +-- before it can be accepted or canceled. +-- +-- Check that the abortable part is aborted if it does not complete +-- before the triggering statement completes. +-- +-- Check that the sequence of statements of the triggering alternative +-- is not executed. +-- +-- TEST DESCRIPTION: +-- Declare a main procedure containing an asynchronous select with a task +-- entry call as triggering statement. Force the entry call to be +-- queued by having the task call a procedure, prior to the corresponding +-- accept statement, which simulates a routine waiting for user input +-- (with a delay). +-- +-- Simulate a time-consuming routine in the abortable part by calling a +-- procedure containing an infinite loop. Meanwhile, simulate input by +-- the user (the delay expires) which is NOT the input expected by the +-- guard on the accept statement. The entry remains closed, and the +-- task completes its execution. Since the entry was not accepted before +-- its task completed, Tasking_Error is raised at the point of the entry +-- call. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package C974005_0 is -- Automated teller machine abstraction. + + + -- Flags for testing purposes: + + Count : Integer := 1234; + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + + Transaction_Canceled : exception; + + + task type ATM_Keyboard_Task is + entry Cancel_Pressed; + end ATM_Keyboard_Task; + + + procedure Read_Card (Card : in out ATM_Card_Type); + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + +private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + +end C974005_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +package body C974005_0 is + + + procedure Listen_For_Input (Key : out Key_Enum) is + begin + -- Simulate the situation where a user waits a bit for the card to + -- be validated, then presses a transaction key (NOT Cancel). + + -- Delay long enough to force queuing of Keyboard.Cancel_Pressed. + delay ImpDef.Clear_Ready_Queue; + + if Report.Equal (3, 3) then -- Always true. + Key := Deposit; -- Cancel is NOT pressed. + end if; + end Listen_For_Input; + + + task body ATM_Keyboard_Task is + Key_Pressed : Key_Enum := None; + begin + + -- Note: no loop. If the user does not press Cancel, the task completes. + -- In this model of the keyboard monitor, the user only gets one chance + -- to cancel the card validation. + -- Force entry + Listen_For_Input (Key_Pressed); -- calls to be + -- queued, but do + -- NOT set guard + -- to true. + select + when (Key_Pressed = Cancel) => -- Guard is false, + accept Cancel_Pressed do -- so entry call + Report.Failed ("Accept statement executed"); -- remains queued. + end Cancel_Pressed; + else -- Else alternative + Key_Pressed := None; -- executed, then + end select; -- task ends. + exception + when others => + Report.Failed ("Unexpected exception in ATM_Keyboard_Task"); + end ATM_Keyboard_Task; + + + + procedure Read_Card (Card : in out ATM_Card_Type) is + begin + Card.Number := 9999; + Card.PIN := 111; + end Read_Card; + + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + -- Simulate an exceedingly long validation activity. + loop -- Infinite loop. + Count := (Count + 1) mod Integer (Card.PIN); + + -- Synch Point to allow transfer of control to Keyboard task + -- during this simulation + delay ImpDef.Minimum_Task_Switch; + + exit when not Report.Equal (Count, Count); -- Always false. + end loop; + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Report.Failed ("Exception not re-raised immediately following " & + "asynchronous select"); + if Count = 1234 then + -- Additional analysis added to aid developers + Report.Failed ("Abortable part did not execute"); + end if; + end Perform_Transaction; + + +end C974005_0; + + + --==================================================================-- + + +with Report; + +with C974005_0; -- Automated teller machine abstraction. +use C974005_0; + +procedure C974005 is + + Card_Data : ATM_Card_Type; + +begin -- Main program. + + Report.Test ("C974005", "ATC: trigger is queued but task terminates" & + " before call is serviced"); + + Read_Card (Card_Data); + + begin + + declare + Keyboard : C974005_0.ATM_Keyboard_Task; + begin + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + Keyboard.Cancel_Pressed; -- Entry call initially queued, so + -- abortable part starts. + + -- Tasking_Error raised here when + -- Keyboard completes before entry + -- call can be accepted, and before + -- abortable part completes. + + raise Transaction_Canceled; -- Should not be executed. + then abort + Validate_Card (Card_Data); -- Keyboard task completes before + -- Keyboard.Cancel_Pressed is + -- accepted, and before this call + -- finishes. Tasking_Error is raised + -- at the point of the entry call, + -- and this call is aborted. + -- Check that the whole of the abortable part is aborted, not just + -- the statement in the abortable part that was executing at + -- the time + Report.Failed ("Abortable part not aborted"); + end select; + Perform_Transaction (Card_Data); -- Should not be reached. + exception + when Transaction_Canceled => + Report.Failed ("Triggering alternative sequence of statements " & + "executed"); + when Tasking_Error => + if Count = 1234 then + Report.Failed ("Abortable part did not execute"); + end if; + when others => + Report.Failed ("Wrong exception raised"); + end; + + exception + when Tasking_Error => + Report.Failed ("Correct exception raised at wrong level"); + when others => + Report.Failed ("Wrong exception raised at wrong level"); + end; + + Report.Result; + +end C974005; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974006.a b/gcc/testsuite/ada/acats/tests/c9/c974006.a new file mode 100644 index 000000000..f6f4d92e8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974006.a @@ -0,0 +1,197 @@ +-- C974006.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the sequence of statements of the triggering alternative +-- of an asynchronous select statement is executed if the triggering +-- statement is a protected entry call, and the entry is accepted +-- immediately. Check that the corresponding entry body is executed +-- before the sequence of statements of the triggering alternative. +-- Check that the abortable part is not executed. +-- +-- TEST DESCRIPTION: +-- Declare a main procedure containing an asynchronous select with a +-- protected entry call as triggering statement. Declare a protected +-- procedure which sets the protected entry's barrier true. Force the +-- entry call to be accepted immediately by calling this protected +-- procedure prior to the asynchronous select. Since the entry call +-- is accepted immediately, the abortable part should never start. When +-- entry call completes, the sequence of statements of the triggering +-- alternative should execute. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +package C974006_0 is -- Automated teller machine abstraction. + + + -- Flag for testing purposes: + + Entry_Body_Executed : Boolean := False; + + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + + Transaction_Canceled : exception; + + + protected type ATM_Keyboard_Protected is + entry Cancel_Pressed; + procedure Read_Key; + private + Last_Key_Pressed : Key_Enum := None; + end ATM_Keyboard_Protected; + + + procedure Read_Card (Card : in out ATM_Card_Type); + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + +private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + +end C974006_0; + + + --==================================================================-- + + +with Report; +package body C974006_0 is + + + protected body ATM_Keyboard_Protected is + + entry Cancel_Pressed when (Last_Key_Pressed = Cancel) is + begin + Entry_Body_Executed := True; + end Cancel_Pressed; + + procedure Read_Key is + begin + -- Simulate a procedure which processes user keyboard input, and + -- which is called by some interrupt handler. + Last_Key_Pressed := Cancel; + end Read_Key; + + end ATM_Keyboard_Protected; + + + procedure Read_Card (Card : in out ATM_Card_Type) is + begin + Card.Number := 9999; + Card.PIN := 111; + end Read_Card; + + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + Report.Failed ("Abortable part executed"); + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Report.Failed ("Triggering alternative sequence of statements " & + "not fully executed"); + end Perform_Transaction; + + +end C974006_0; + + + --==================================================================-- + + +with Report; + +with C974006_0; -- Automated teller machine abstraction. +use C974006_0; + +procedure C974006 is + + Card_Data : ATM_Card_Type; + +begin + + Report.Test ("C974006", "ATC: trigger is protected entry call" & + " and completes first"); + + Read_Card (Card_Data); + + declare + Keyboard : C974006_0.ATM_Keyboard_Protected; + begin + + -- Simulate the situation where the user hits cancel before the + -- validation process can start: + Keyboard.Read_Key; -- Force Keyboard.Cancel_Pressed to + -- be accepted immediately. + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + Keyboard.Cancel_Pressed; -- Entry call is accepted immediately, + -- so abortable part does NOT start. + + if not Entry_Body_Executed then -- Executes after entry completes. + Report.Failed ("Triggering alternative sequence of statements " & + "executed before triggering statement complete"); + end if; + + raise Transaction_Canceled; -- Control passes to exception + -- handler. + then abort + Validate_Card (Card_Data); -- Should not be executed. + end select; + Perform_Transaction (Card_Data); -- Should not be reached. + exception + when Transaction_Canceled => + null; + end; + + Report.Result; + +end C974006; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974007.a b/gcc/testsuite/ada/acats/tests/c9/c974007.a new file mode 100644 index 000000000..07007b9bb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974007.a @@ -0,0 +1,205 @@ +-- C974007.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the sequence of statements of the triggering alternative +-- of an asynchronous select statement is not executed if the triggering +-- statement is a protected entry call, and the entry is not accepted +-- before the abortable part completes. Check that execution continues +-- immediately following the asynchronous select. +-- +-- TEST DESCRIPTION: +-- Declare a main procedure containing an asynchronous select with a +-- protected entry call as triggering statement. Declare a protected +-- procedure which sets the protected entry's barrier true. Ensure +-- that the entry call is never accepted by not calling the protected +-- procedure; the barrier remains false, and the entry call from +-- asynchronous select is queued. Since the abortable part will complete +-- before the entry is accepted, the sequence of statements of the +-- triggering alternative is never executed. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +package C974007_0 is -- Automated teller machine abstraction. + + + -- Flags for testing purposes: + -- + Abortable_Part_Executed : Boolean := False; + Perform_Transaction_Executed : Boolean := False; + Triggering_Statement_Executed : Boolean := False; + + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + + Transaction_Canceled : exception; + + + protected type ATM_Keyboard_Protected is + entry Cancel_Pressed; + procedure Read_Key; + private + Last_Key_Pressed : Key_Enum := None; + end ATM_Keyboard_Protected; + + + procedure Read_Card (Card : in out ATM_Card_Type); + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + +private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + +end C974007_0; + + + --==================================================================-- + + +with Report; +package body C974007_0 is + + + protected body ATM_Keyboard_Protected is + + -- Barrier is false for the live of the test + entry Cancel_Pressed when (Last_Key_Pressed = Cancel) is + begin + Triggering_Statement_Executed := true; -- Test has failed + -- (Note: cannot call Report.Failed in the protected entry body] + end Cancel_Pressed; + + procedure Read_Key is -- Never + begin -- called. + -- Simulate a procedure which reads user keyboard input, and + -- which is called by some interrupt handler. + Last_Key_Pressed := Cancel; + end Read_Key; + + end ATM_Keyboard_Protected; + + + procedure Read_Card (Card : in out ATM_Card_Type) is + begin + Card.Number := 9999; + Card.PIN := 111; + end Read_Card; + + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + Abortable_Part_Executed := True; + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Perform_Transaction_Executed := True; + end Perform_Transaction; + + +end C974007_0; + + + --==================================================================-- +with Report; + +with C974007_0; -- Automated teller machine abstraction. +use C974007_0; + +procedure C974007 is + + Card_Data : ATM_Card_Type; + +begin + + Report.Test ("C974007", "ATC: trigger is protected entry call" & + " and abortable part completes first"); + + Read_Card (Card_Data); + + declare + Keyboard : C974007_0.ATM_Keyboard_Protected; + begin + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + Keyboard.Cancel_Pressed; -- Barrier is never set true, so + -- entry call is queued and never + -- accepted. + + raise Transaction_Canceled; -- Should not be executed. + then abort + Validate_Card (Card_Data); -- This call completes before + -- Keyboard.Cancel_Pressed can be + -- accepted. + end select; + Perform_Transaction (Card_Data); -- Execution proceeds here after + -- Validate_Card completes. + exception + when Transaction_Canceled => + Report.Failed ("Triggering alternative sequence of statements " & + "executed"); + end; + + + if Triggering_Statement_Executed then + Report.Failed ("Triggering statement was executed"); + end if; + + if not Abortable_Part_Executed then + Report.Failed ("Abortable part not executed"); + end if; + + if not Perform_Transaction_Executed then + Report.Failed ("Statements following asynchronous select not " & + "executed"); + end if; + + Report.Result; + +end C974007; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974008.a b/gcc/testsuite/ada/acats/tests/c9/c974008.a new file mode 100644 index 000000000..b76db7bd0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974008.a @@ -0,0 +1,229 @@ +-- C974008.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the abortable part of an asynchronous select statement +-- is not started if the triggering statement is a task entry call, and +-- the entry call is not queued. +-- +-- Check that the sequence of statements of the triggering alternative +-- is executed after the abortable part is left. +-- +-- TEST DESCRIPTION: +-- Declare a main procedure containing an asynchronous select with a task +-- entry call as triggering statement. Ensure that the task is waiting +-- at the accept statement so the rendezvous is executed immediately (the +-- entry call is not queued). +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package C974008_0 is -- Automated teller machine abstraction. + + + -- Flags for testing purposes: + + Triggering_Statement_Completed : Boolean := False; + Count : Integer := 1234; -- Global to defeat + -- optimization. + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + + Transaction_Canceled : exception; + + + task type ATM_Keyboard_Task is + entry Cancel_Pressed; + end ATM_Keyboard_Task; + + + procedure Read_Card (Card : in out ATM_Card_Type); + + + procedure Perform_Transaction (Card : in ATM_Card_Type); + +private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + +end C974008_0; + + + --==================================================================-- + + +with Report; +package body C974008_0 is + + + procedure Listen_For_Input (Key : out Key_Enum) is + begin + -- Simulate the situation where the user presses the cancel key + -- before the card is validated + + -- press the cancel key immediately + Key := Cancel; + + end Listen_For_Input; + + + + -- One of these gets created as "Keyboard" for each transaction + -- + task body ATM_Keyboard_Task is + Key_Pressed : Key_Enum := None; + begin + -- NOTE: Normal usage for this routine would be the loop with + -- the select statement included. This particular test + -- requires that the task be waiting at the accept + -- for the call. To ensure that this is the case the + -- extraneous commands are commented out (we leave them + -- in this form to show the reader the surrounds to the + -- fragment of code remaining) + + -- loop + + Listen_For_Input (Key_Pressed); + + -- select + -- when (Key_Pressed = Cancel) => -- Guard is now + accept Cancel_Pressed do -- true, so accept + Triggering_Statement_Completed := True; -- queued entry + end Cancel_Pressed; -- call. + + -- User has cancelled the transaction so we exit the + -- loop and allow the task to terminate + -- exit; + -- else + -- Key_Pressed := None; + -- end select; + + -- end loop; + exception + when others => + Report.Failed ("Unexpected Exception in ATM_Keyboard_Task"); + end ATM_Keyboard_Task; + + + + procedure Read_Card (Card : in out ATM_Card_Type) is + begin + Card.Number := 9999; + Card.PIN := 111; + end Read_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Report.Failed ("Triggering alternative sequence of statements " & + "not executed"); + if not Triggering_Statement_Completed then + Report.Failed ("Triggering statement did not complete"); + end if; + end Perform_Transaction; + + +end C974008_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +with C974008_0; -- Automated teller machine abstraction. +use C974008_0; + +procedure C974008 is + + Card_Data : ATM_Card_Type; + +begin -- Main program. + + Report.Test ("C974008", "Asynchronous Select: Trigger is a call to a " & + "waiting task entry and completes immediately"); + + Read_Card (Card_Data); + + declare + -- Create the task for this transaction + Keyboard : C974008_0.ATM_Keyboard_Task; + begin + + -- Ensure task is waiting at the accept + -- This is the time required to activate another task and allow it + -- to run to its first accept statement. + -- + delay ImpDef.Switch_To_New_Task; + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + Keyboard.Cancel_Pressed; -- Entry call is executed immediately + + raise Transaction_Canceled; -- This is executed after Validate_Card + -- is aborted. + then abort + + -- In other similar tests Validate_Card is called here. In this + -- test we just check to see if the abortable part is called at + -- all. Since the triggering call is not queued the abortable + -- part should not be started + -- + Report.Failed ("Abortable part started"); + + end select; + + Perform_Transaction (Card_Data); -- Should not be reached. + exception + when Transaction_Canceled => + + if not Triggering_Statement_Completed then + Report.Failed ("Triggering alternative sequence of statements " & + "executed but triggering statement not complete"); + end if; + + end; + + Report.Result; + +end C974008; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974009.a b/gcc/testsuite/ada/acats/tests/c9/c974009.a new file mode 100644 index 000000000..419f2a3e9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974009.a @@ -0,0 +1,206 @@ +-- C974009.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the abortable part of an asynchronous select statement +-- is not started if the triggering statement is a task entry call, +-- the entry call is not queued and the entry call completes by +-- propagating an exception. +-- +-- Check that the exception is properly propagated to the asynchronous +-- select statement and thus the sequence of statements of the triggering +-- alternative is not executed after the abortable part is left. +-- +-- Check that the exception propagated by the entry call is re-raised +-- immediately following the asynchronous select. +-- +-- TEST DESCRIPTION: +-- +-- Use a small subset of the base Automated teller machine simulation +-- which is shown in greater detail in other tests of this series. +-- Declare a main procedure containing an asynchronous select with a task +-- entry call as triggering statement. Force the task to be waiting at +-- the accept statement so that the call is not queued and the rendezvous +-- is executed immediately. Simulate an unexpected exception in the +-- rendezvous. Use stripped down versions of called procedures to check +-- the correct path in the test. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +package C974009_0 is -- Automated teller machine abstraction. + + + Propagated_From_Task : exception; + Transaction_Canceled : exception; + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + task type ATM_Keyboard_Task is + entry Cancel_Pressed; + end ATM_Keyboard_Task; + + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + + +private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + +end C974009_0; + + + --==================================================================-- + + +with Report; +package body C974009_0 is + + + + -- One of these gets created as "Keyboard" for each transaction + -- + task body ATM_Keyboard_Task is + Key_Pressed : Key_Enum := None; + begin + accept Cancel_Pressed do -- queued entry call. + null; --:::: stub, user code for cancel + -- Now simulate an unexpected exception arising in the + -- user code + raise Propagated_From_Task; -- Propagate an exception. + + end Cancel_Pressed; + + Report.Failed ("Exception not propagated in ATM_Keyboard_Task"); + + exception + when Propagated_From_Task => + null; -- This is the expected test behavior + when others => + Report.Failed ("Unexpected Exception in ATM_Keyboard_Task"); + end ATM_Keyboard_Task; + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + Report.Failed ("Abortable part was executed"); + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Report.Failed ("Exception not re-raised immediately following " & + "asynchronous select"); + end Perform_Transaction; + + +end C974009_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +with C974009_0; -- Automated teller machine abstraction. +use C974009_0; + +procedure C974009 is + + Card_Data : ATM_Card_Type; + +begin -- Main program. + + Report.Test ("C974009", "Asynchronous Select: Trigger is a call to a " & + "task entry, is not queued and is completed " & + "first by an exception"); + + + begin + + declare + -- Create the task for this transaction + Keyboard : C974009_0.ATM_Keyboard_Task; + begin + + -- Ensure task is waiting a the accept so the call is not queued + -- This is the time required to activate another task and allow it + -- to run to its first accept statement + -- + delay ImpDef.Switch_To_New_Task; + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + + Keyboard.Cancel_Pressed; + + raise Transaction_Canceled; -- Should not be executed. + then abort + Validate_Card (Card_Data); -- Keyboard.Cancel_Pressed is accepted + -- and propagates an exception before + -- this call is executed + end select; + + -- The propagated exception is re-raised here. + Perform_Transaction(Card_Data); -- Should not be reached. + + exception + when Transaction_Canceled => + Report.Failed ("Triggering alternative sequence of statements " & + "executed"); + when Propagated_From_Task => + null; -- This is the expected test path + when others => + Report.Failed ("Wrong exception raised"); + end; + + exception + when others => + Report.Failed ("Unexpected exception raised"); + end; + + Report.Result; + +end C974009; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974010.a b/gcc/testsuite/ada/acats/tests/c9/c974010.a new file mode 100644 index 000000000..caeb9d570 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974010.a @@ -0,0 +1,209 @@ +-- C974010.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the abortable part of an asynchronous select statement +-- is not started if the triggering statement is a task entry call to +-- a task that has already terminated. +-- +-- Check that Tasking_Error is properly propagated to the asynchronous +-- select statement and thus the sequence of statements of the triggering +-- alternative is not executed after the abortable part is left. +-- +-- Check that Tasking_Error is re-raised immediately following the +-- asynchronous select. +-- +-- TEST DESCRIPTION: +-- +-- Use a small subset of the base Automated Teller Machine simulation +-- which is shown in greater detail in other tests of this series. +-- Declare a main procedure containing an asynchronous select with a task +-- entry call as triggering statement. Ensure that the task is +-- terminated before the entry call. Use stripped down versions of +-- the called procedures to check the correct path in the test. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +package C974010_0 is -- Automated teller machine abstraction. + + + Transaction_Canceled : exception; + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + task type ATM_Keyboard_Task is + entry Cancel_Pressed; + end ATM_Keyboard_Task; + + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + + +private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + +end C974010_0; + + + --==================================================================-- + + +with Report; +package body C974010_0 is + + + + -- One of these gets created as "Keyboard" for each transaction + -- + task body ATM_Keyboard_Task is + TC_Suicide : exception; + Key_Pressed : Key_Enum := None; + begin + raise TC_Suicide; -- Simulate early, unexpected termination + + accept Cancel_Pressed do -- queued entry call. + null; --:::: user code for cancel + + end Cancel_Pressed; + + exception + when TC_Suicide => + null; -- This is the expected test behavior + when others => + Report.Failed ("Unexpected Exception in ATM_Keyboard_Task"); + end ATM_Keyboard_Task; + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + Report.Failed ("Abortable part was executed"); + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Report.Failed ("Exception not re-raised immediately following " & + "asynchronous select"); + end Perform_Transaction; + + +end C974010_0; + + + --==================================================================-- + + +with Report; +with ImpDef; + +with C974010_0; -- Automated teller machine abstraction. +use C974010_0; + +procedure C974010 is + + Card_Data : ATM_Card_Type; + TC_Tasking_Error_Handled : Boolean := false; + +begin -- Main program. + + Report.Test ("C974010", "Asynchronous Select: Trigger is a call to a " & + "task entry of a task that is already completed"); + + + declare + -- Create the task for this transaction + Keyboard : C974010_0.ATM_Keyboard_Task; + begin + + -- Ensure the task is already completed before calling + -- + while not Keyboard'terminated loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + + Keyboard.Cancel_Pressed; + + raise Transaction_Canceled; -- Should not be executed. + + then abort + + -- Since the triggering call is not queued the abortable part + -- should not be executed. + -- + Validate_Card (Card_Data); + + end select; + -- + -- The propagated exception is re-raised here. + + Perform_Transaction(Card_Data); -- Should not be reached. + + exception + when Transaction_Canceled => + Report.Failed ("Triggering alternative sequence of statements " & + "executed"); + when Tasking_Error => + -- This is the expected test path + TC_Tasking_Error_Handled := true; + when others => + Report.Failed ("Wrong exception raised: "); + end; + + + if not TC_Tasking_Error_Handled then + Report.Failed ("Tasking_Error not properly propagated"); + end if; + + Report.Result; + +exception + when Tasking_Error => + Report.Failed ("Tasking_Error propagated to wrong handler"); + Report.Result; + + +end C974010; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974011.a b/gcc/testsuite/ada/acats/tests/c9/c974011.a new file mode 100644 index 000000000..4682db628 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974011.a @@ -0,0 +1,275 @@ +-- C974011.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the sequence of statements of the triggering alternative +-- of an asynchronous select statement is not executed if the triggering +-- statement is a task entry call and the entry is not accepted +-- before the abortable part completes. +-- Check that the call queued on the entry is cancelled +-- +-- TEST DESCRIPTION: +-- Declare a main procedure containing an asynchronous select with a task +-- entry call as triggering statement. Force the entry call to be +-- queued by having the task call a procedure, prior to the corresponding +-- accept statement, which simulates (with a delay) a routine waiting +-- for user input +-- +-- Once the call is known to be queued, complete the abortable part. +-- Check that the rendezvous (and thus the trigger) does not complete. +-- Then clear the barrier and check that the entry has been cancelled +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 28 Nov 95 SAIC Eliminated shared global variable for ACVC 2.0.1 +-- +--! + +with ImpDef; +-- +package C974011_0 is -- Automated teller machine abstraction. + + + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + protected Key_PO is + procedure Set (K : Key_Enum); + function Value return Key_Enum; + private + Current : Key_Enum := None; + end Key_PO; + + + -- Flags for testing purposes + TC_Abortable_Part_Completed : Boolean := False; + TC_Rendezvous_Entered : Boolean := False; + TC_Delay_Time : constant duration := ImpDef.Switch_To_New_Task; + + + Count : Integer := 1234; -- Global to defeat optimization. + + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + + Transaction_Canceled : exception; + + + task type ATM_Keyboard_Task is + entry Cancel_Pressed; + end ATM_Keyboard_Task; + + procedure Read_Card (Card : in out ATM_Card_Type); + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + +private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + +end C974011_0; + + + --==================================================================-- + + +with Report; +package body C974011_0 is + + protected body Key_PO is + procedure Set (K : Key_Enum) is + begin + Current := K; + end Set; + + function Value return Key_Enum is + begin + return Current; + end Value; + end Key_PO; + + + procedure Listen_For_Input (Key : out Key_Enum) is + begin + -- Model the situation where the user does not press cancel thus + -- allowing validation to complete + + delay TC_Delay_Time; -- Long enough to force queuing on + -- Keyboard.Cancel_Pressed. + + Key := Key_PO.Value; + + end Listen_For_Input; + + + + -- One of these gets created as "Keyboard" for each transaction + -- + task body ATM_Keyboard_Task is + Key_Pressed : Key_Enum; + begin + loop + -- Force entry calls + Listen_For_Input (Key_Pressed); -- to be queued, + + select + when (Key_Pressed = Cancel) => + accept Cancel_Pressed do + TC_Rendezvous_Entered := True; + end Cancel_Pressed; + + -- User has cancelled the transaction so we exit the + -- loop and allow the task to terminate + exit; + else + delay ImpDef.Switch_To_New_Task; + end select; + + end loop; + exception + when others => + Report.Failed ("Unexpected Exception in ATM_Keyboard_Task"); + end ATM_Keyboard_Task; + + + + procedure Read_Card (Card : in out ATM_Card_Type) is + begin + Card.Number := 9999; + Card.PIN := 111; + end Read_Card; + + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + Count := (Count + 1) mod Integer (Card.PIN); + + -- Simulate a validation activity which is longer than the time + -- taken in Listen_For_Input but not inordinately so. + delay TC_Delay_Time * 2; + + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + if TC_Rendezvous_Entered then + Report.Failed ("Triggering statement completed"); + end if; + if Count = 1234 then + -- Initial value is unchanged + Report.Failed ("Abortable part did not execute"); + end if; + if not TC_Abortable_Part_Completed then + Report.Failed ("Abortable part did not complete"); + end if; + end Perform_Transaction; + + +end C974011_0; + + + --==================================================================-- + + +with Report; + +with C974011_0; -- Automated teller machine abstraction. +use C974011_0; + +procedure C974011 is + + Card_Data : ATM_Card_Type; + +begin -- Main program. + + Report.Test ("C974011", "Asynchronous Select: Trigger is queued on a " & + "task entry and the abortable part " & + "completes first"); + + Read_Card (Card_Data); + + declare + -- Create the task for this transaction + Keyboard : C974011_0.ATM_Keyboard_Task; + begin + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + + Keyboard.Cancel_Pressed; -- Entry call is initially queued, so + -- abortable part starts. + raise Transaction_Canceled; -- This would be executed if we + -- completed the rendezvous + then abort + + Validate_Card (Card_Data); + TC_Abortable_Part_Completed := true; + + end select; + + Perform_Transaction (Card_Data); + + + -- Now clear the entry barrier to allow the rendezvous to complete + -- if the triggering call has not been cancelled + Key_PO.Set (Cancel); + -- + delay TC_Delay_Time; -- to allow it all to take place + + if TC_Rendezvous_Entered then + Report.Failed ("Triggering Call was not cancelled"); + end if; + + abort Keyboard; -- clean up. (Note: the task will only exit the + -- loop and terminate if the call hanging on the + -- entry is executed.) + + exception + when Transaction_Canceled => + Report.Failed ("Triggering alternative sequence of statements " & + "executed"); + when Others => + Report.Failed ("Unexpected exception in the Main"); + end; + + Report.Result; + +end C974011; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974012.a b/gcc/testsuite/ada/acats/tests/c9/c974012.a new file mode 100644 index 000000000..4e43c72a8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974012.a @@ -0,0 +1,165 @@ +-- C974012.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the abortable part of an asynchronous select statement is +-- aborted if it does not complete before the triggering statement +-- completes, where the triggering statement is a call on a protected +-- entry which is queued. +-- +-- TEST DESCRIPTION: +-- A fraction of in-line code is simulated. A voltage deficiency causes +-- the routine to seek an alternate best-cost route on an electrical grid +-- system. +-- +-- An asynchronous select is used with the triggering alternative being a +-- call to a protected entry with a barrier. The abortable part is a +-- routine simulating the lengthy alternate path negotiation. The entry +-- barrier would be cleared if the voltage deficiency is rectified before +-- the alternate can be found thus nullifying the need for the alternate. +-- +-- The test simulates a return to normal in the middle of the +-- negotiation. The barrier is cleared, the triggering alternative +-- completes first and the abortable part should be aborted. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +with Report; +with ImpDef; + +procedure C974012 is + + subtype Grid_Path is string(1..21); + subtype Deficiency is integer range 100..1_000; -- in MWh + + New_Path : Grid_Path; + Dummy_Deficiency : Deficiency := 520; + Path_Available : Boolean := false; + + TC_Terminate_Negotiation_Executed : Boolean := false; + TC_Trigger_Completed : Boolean := false; + TC_Negotiation_Completed : Boolean := false; + + protected Local_Deficit is + procedure Set_Good_Voltage; + procedure Bad_Voltage; + entry Terminate_Negotiation; + private + Good_Voltage : Boolean := false; -- barrier + end Local_Deficit; + + protected body Local_Deficit is + + procedure Set_Good_Voltage is + begin + Good_Voltage := true; + end Set_Good_Voltage; + + procedure Bad_Voltage is + begin + Good_Voltage := false; + end Bad_Voltage; + + -- Trigger is queued on this entry with barrier condition + entry Terminate_Negotiation when Good_Voltage is + begin + -- complete the triggering call thus terminating grid_path + -- negotiation. + null; --::: stub - signal main board + TC_Terminate_Negotiation_Executed := true; -- show path traversal + end Terminate_Negotiation; + + end Local_Deficit; + + + -- Routine to find the most cost effective grid path for this + -- particular deficiency at this particular time + -- + procedure Path_Negotiation (Requirement : in Deficiency; + Best_Path : out Grid_Path ) is + + Dummy_Path : Grid_Path := "NYC.425_NY.227_NH.132"; + Match : Deficiency := Report.Ident_Int (Requirement); + + begin + -- + null; --::: stub + -- + -- Simulate a lengthy path negotiation + for i in 1..5 loop + delay ImpDef.Minimum_Task_Switch; + -- Part of the way through the negotiation simulate some external + -- event returning the voltage to acceptable level + if i = 3 then + Local_Deficit.Set_Good_Voltage; -- clear the barrier + end if; + end loop; + + Best_Path := Dummy_Path; + TC_Negotiation_Completed := true; + + end Path_Negotiation; + + + +begin + + Report.Test ("C974012", "Asynchronous Select: Trigger is queued on a " & + "protected entry and completes before the " & + "abortable part"); + + -- ::::::::: Fragment of code + + Local_Deficit.Bad_Voltage; -- Set barrier condition + + -- For the given voltage deficiency start negotiating the best grid + -- path. If voltage returns to acceptable level cancel the negotiation + -- + select + -- Prepare to terminate the Path_Negotiation if voltage improves + Local_Deficit.Terminate_Negotiation; + TC_Trigger_Completed := true; + then abort + Path_Negotiation (Dummy_Deficiency, New_Path) ; + Path_Available := true; + end select; + -- ::::::::: + + if not TC_Terminate_Negotiation_Executed or else not + TC_Trigger_Completed then + Report.Failed ("Unexpected test path taken"); + end if; + + if Path_Available or else TC_Negotiation_Completed then + Report.Failed ("Abortable part was not aborted"); + end if; + Report.Result; + +end C974012; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974013.a b/gcc/testsuite/ada/acats/tests/c9/c974013.a new file mode 100644 index 000000000..4a930da93 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974013.a @@ -0,0 +1,167 @@ +-- C974013.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that the abortable part of an asynchronous select statement +-- is aborted if it does not complete before the triggering statement +-- completes, where the triggering statement is a delay_until +-- statement. +-- +-- Check that the sequence of statements of the triggering alternative +-- is executed after the abortable part is left. +-- +-- TEST DESCRIPTION: +-- Declare a task with an accept statement containing an asynchronous +-- select with a delay_until triggering statement. Parameterize +-- the accept statement with the amount of time to be added to the +-- current time to be used for the delay. Simulate a time-consuming +-- calculation by declaring a procedure containing an infinite loop. +-- Call this procedure in the abortable part. +-- +-- The delay will expire before the abortable part completes, at which +-- time the abortable part is aborted, and the sequence of statements +-- following the triggering statement is executed. +-- +-- Main test logic is identical to c974001 which uses simple delay +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 28 Nov 95 SAIC Fixed problems for ACVC 2.0.1. +-- +--! + +with Report; +with ImpDef; +with Ada.Calendar; + +procedure C974013 is + + + --========================================================-- + + function "+" (Left : Ada.Calendar.Time; Right: Duration) + return Ada.Calendar.Time renames Ada.Calendar."+"; + + + Allotted_Time : constant Duration := ImpDef.Switch_To_New_Task; + Calculation_Canceled : exception; + + Count : Integer := 1234; + procedure Lengthy_Calculation is + begin + -- Simulate a non-converging calculation. + loop -- Infinite loop. + Count := (Count + 1) mod 10; + exit when not Report.Equal (Count, Count); -- Condition always false. + delay 0.0; -- abort completion point + end loop; + end Lengthy_Calculation; + + + --========================================================-- + + + task type Timed_Calculation is + entry Calculation (Time_Limit : in Duration); + end Timed_Calculation; + + + task body Timed_Calculation is + Delay_Time : Ada.Calendar.Time; + begin + loop + select + accept Calculation (Time_Limit : in Duration) do + + -- We have to construct an "until" time artificially + -- as we have no control over when the test will be run + -- + Delay_Time := Ada.Calendar.Clock + Time_Limit; + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + + delay until Delay_Time; -- Time not reached yet, so + -- Lengthy_Calculation starts. + + raise Calculation_Canceled; -- This is executed after + -- Lengthy_Calculation aborted. + + then abort + + Lengthy_Calculation; -- Delay expires before complete, + -- so this call is aborted. + -- Check that the whole of the abortable part is aborted, + -- not just the statement in the abortable part that was + -- executing at the time + Report.Failed ("Abortable part not aborted"); + + end select; + + Report.Failed ("Triggering alternative sequence of " & + "statements not executed"); + + exception -- New Ada 9x: handler within accept + when Calculation_Canceled => + if Count = 1234 then + Report.Failed ("Abortable part did not execute"); + end if; + end Calculation; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Timed_Calculation task"); + end Timed_Calculation; + + + --========================================================-- + + + +begin -- Main program. + + Report.Test ("C974013", "Asynchronous Select: Trigger is delay_until " & + "which completes before abortable part"); + + declare + Timed : Timed_Calculation; -- Task. + begin + Timed.Calculation (Time_Limit => Allotted_Time); -- Asynchronous select + -- inside accept block. + exception + when Calculation_Canceled => + Report.Failed ("wrong exception handler used"); + end; + + Report.Result; + +end C974013; diff --git a/gcc/testsuite/ada/acats/tests/c9/c974014.a b/gcc/testsuite/ada/acats/tests/c9/c974014.a new file mode 100644 index 000000000..03ca915f8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c974014.a @@ -0,0 +1,132 @@ +-- C974014.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that if the triggering alternative of an asynchronous select +-- statement is a delay and the abortable part completes before the delay +-- expires then the delay is cancelled and the optional statements in the +-- triggering part are not performed. In particular, check the case of +-- the ATC in non-tasking code. +-- +-- TEST DESCRIPTION: +-- A fraction of in-line code is simulated. An asynchronous select +-- is used with a triggering delay of several minutes. The abortable +-- part, which is simulating a very lengthy, time consuming procedure +-- actually returns almost immediately thus ensuring that it completes +-- first. At the conclusion, if a substantial amount of time has passed +-- the delay is assumed not to have been cancelled. +-- (based on example in LRM 9.7.4) +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + + +with Report; +with Ada.Calendar; + +procedure C974014 is + + function "-" (Left, Right : Ada.Calendar.Time) + return Duration renames Ada.Calendar."-"; + + TC_Start_Time : Ada.Calendar.Time := Ada.Calendar.Clock; + TC_Elapsed_Time : duration; + + Maximum_Allowable_Time : duration := 300.0; -- for Calculate_Gamma_Function + +begin + + Report.Test ("C974014", "ATC: When abortable part completes before " & + "a triggering delay, check that the delay " & + "is cancelled & optional statements " & + "are not performed"); + + declare -- encapsulate test code + + type Gamma_Index is digits 5; -- float precision + + -- (These two fields are assumed filled elsewhere) + Input_Field, Result_of_Beta : Gamma_Index; + + -- Notify and take corrective action in the event that + -- the procedure Calculate_Gamma_Function does not converge. + -- + procedure Non_Convergent is + begin + null; -- stub + + Report.Failed ("Optional statements in triggering part" & + " were performed"); + end Non_Convergent; + + + -- This is a very time consuming calculation. It is possible, + -- that, with certain parameters, it will not converge. If it + -- runs for more than Maximum_Allowable_Time it is considered + -- not to be convergent and should be aborted. + -- + Procedure Calculate_Gamma_Function (X, Y : Gamma_Index) is + begin + null; -- Stub + -- + end Calculate_Gamma_Function; + + begin -- declare + + -- ..... Isolated segment of inline code + + -- Now Print Gamma Function (abort and display if not convergent) + -- + select + delay Maximum_Allowable_Time; -- for Calculate_Gamma_Function + Non_Convergent; -- Display error and flag result as failed + + then abort + Calculate_Gamma_Function (Input_Field, Result_of_Beta); + end select; + + -- ..... End of Isolated segment of inline code + + end; -- declare + + TC_Elapsed_Time := Ada.Calendar.Clock - TC_Start_Time; + + -- Note: We are not checking for "cancellation within a reasonable time", + -- we are checking for cancellation/non-cancellation of the delay. We + -- use a number which, if exceeded, means that the delay was not + -- cancelled and has proceeded to full term. + -- + if ( TC_Elapsed_Time > Maximum_Allowable_Time/2 ) then + -- Test time exceeds a reasonable value. + Report.Failed ("Triggering delay statement was not cancelled"); + end if; + + + Report.Result; + +end C974014; diff --git a/gcc/testsuite/ada/acats/tests/c9/c980001.a b/gcc/testsuite/ada/acats/tests/c9/c980001.a new file mode 100644 index 000000000..3bd4196f0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c980001.a @@ -0,0 +1,303 @@ +-- C980001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that when a construct is aborted the execution of an Initialize +-- procedure as the last step of the default initialization of a +-- controlled object is abort-deferred. +-- +-- Check that when a construct is aborted the execution of a Finalize +-- procedure as part of the finalization of a controlled object is +-- abort-deferred. +-- +-- Check that an assignment operation to an object with a controlled +-- part is an abort-deferred operation. +-- +-- TEST DESCRIPTION: +-- The controlled operations which are being tested call a subprogram +-- which guarantees that the enclosing operation becomes aborted. +-- +-- Each object is created with a unique value to prevent optimizations +-- due to the values being the same. +-- +-- Two protected objects are utilized to warrant that the operations +-- are delayed in their execution until such time that the abort is +-- processed. The object Hold_Up is used to hold the targeted +-- operation in execution, the object Progress is used to communicate +-- to the driver software that progress is indeed being made. +-- +-- +-- CHANGE HISTORY: +-- 01 MAY 95 SAIC Initial version +-- 01 MAY 96 SAIC Revised for 2.1 +-- 11 DEC 96 SAIC Final revision for 2.1 +-- 02 DEC 97 EDS Remove 2 calls to C980001_0.Hold_Up.Lock +--! + +---------------------------------------------------------------- C980001_0 + +with Impdef; +with Ada.Finalization; +package C980001_0 is + + A_Little_While : constant Duration := Impdef.Switch_To_New_Task * 2.0; + Enough_Time_For_The_Controlled_Operation_To_Happen : constant Duration + := Impdef.Switch_To_New_Task * 4.0; + + function TC_Unique return Integer; + + type Sticks_In_Initialize is new Ada.Finalization.Controlled with record + Item: Integer := TC_Unique; + end record; + procedure Initialize( AV: in out Sticks_In_Initialize ); + + type Sticks_In_Adjust is new Ada.Finalization.Controlled with record + Item: Integer := TC_Unique; + end record; + procedure Adjust ( AV: in out Sticks_In_Adjust ); + + type Sticks_In_Finalize is new Ada.Finalization.Controlled with record + Item: Integer := TC_Unique; + end record; + procedure Finalize ( AV: in out Sticks_In_Finalize ); + + Initialize_Called : Boolean := False; + Adjust_Called : Boolean := False; + Finalize_Called : Boolean := False; + + protected type Sticker is + entry Lock; + procedure Unlock; + function Is_Locked return Boolean; + private + Locked : Boolean := False; + end Sticker; + + Hold_Up : Sticker; + Progress : Sticker; + + procedure Fail_And_Clear( Message : String ); + + +end C980001_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +with TCTouch; +package body C980001_0 is + + TC_Master_Value : Integer := 0; + + + function TC_Unique return Integer is -- make all values unique. + begin + TC_Master_Value := TC_Master_Value +1; + return TC_Master_Value; + end TC_Unique; + + protected body Sticker is + + entry Lock when not Locked is + begin + Locked := True; + end Lock; + + procedure Unlock is + begin + Locked := False; + end Unlock; + + function Is_Locked return Boolean is + begin + return Locked; + end Is_Locked; + + end Sticker; + + procedure Initialize( AV: in out Sticks_In_Initialize ) is + begin + TCTouch.Touch('I'); -------------------------------------------------- I + Hold_Up.Unlock; -- cause the select to abort + Initialize_Called := True; + AV.Item := TC_Unique; + TCTouch.Touch('i'); -------------------------------------------------- i + Progress.Unlock; -- allows Wait_Your_Turn to continue + end Initialize; + + procedure Adjust ( AV: in out Sticks_In_Adjust ) is + begin + TCTouch.Touch('A'); -------------------------------------------------- A + Hold_Up.Unlock; -- cause the select to abort + Adjust_Called := True; + AV.Item := TC_Unique; + TCTouch.Touch('a'); -------------------------------------------------- a + Progress.Unlock; + end Adjust; + + procedure Finalize ( AV: in out Sticks_In_Finalize ) is + begin + TCTouch.Touch('F'); -------------------------------------------------- F + Hold_Up.Unlock; -- cause the select to abort + Finalize_Called := True; + AV.Item := TC_Unique; + TCTouch.Touch('f'); -------------------------------------------------- f + Progress.Unlock; + end Finalize; + + procedure Fail_And_Clear( Message : String ) is + begin + Report.Failed(Message); + Hold_Up.Unlock; + Progress.Unlock; + end Fail_And_Clear; + +end C980001_0; + +--------------------------------------------------------------------------- + +with Report; +with TCTouch; +with Impdef; +with C980001_0; +procedure C980001 is + + procedure Check_Initialize_Conditions is + begin + if not C980001_0.Initialize_Called then + C980001_0.Fail_And_Clear("Initialize did not correctly complete"); + end if; + TCTouch.Validate("Ii", "Initialization Sequence"); + end Check_Initialize_Conditions; + + procedure Check_Adjust_Conditions is + begin + if not C980001_0.Adjust_Called then + C980001_0.Fail_And_Clear("Adjust did not correctly complete"); + end if; + TCTouch.Validate("Aa", "Adjust Sequence"); + end Check_Adjust_Conditions; + + procedure Check_Finalize_Conditions is + begin + if not C980001_0.Finalize_Called then + C980001_0.Fail_And_Clear("Finalize did not correctly complete"); + end if; + TCTouch.Validate("FfFfFf", "Finalization Sequence", + Order_Meaningful => False); + end Check_Finalize_Conditions; + + procedure Wait_Your_Turn is + Overrun : Natural := 0; + begin + while C980001_0.Progress.Is_Locked loop -- and waits + delay C980001_0.A_Little_While; + Overrun := Overrun +1; + if Overrun > 10 then + C980001_0.Fail_And_Clear("Overrun expired lock"); + end if; + end loop; + end Wait_Your_Turn; + +begin -- Main test procedure. + + Report.Test ("C980001", "Check the interaction between asynchronous " & + "transfer of control and controlled types" ); + + C980001_0.Progress.Lock; + C980001_0.Hold_Up.Lock; + + select + C980001_0.Hold_Up.Lock; -- Init will unlock + + Wait_Your_Turn; -- abortable part is stuck in Initialize + Check_Initialize_Conditions; + + then abort + declare + Object : C980001_0.Sticks_In_Initialize; + begin + delay Impdef.Minimum_Task_Switch; + if Report.Ident_Int( Object.Item ) /= Object.Item then + Report.Failed("Optimization foil caused failure"); + end if; + C980001_0.Fail_And_Clear( + "Initialize test executed beyond expected region"); + end; + end select; + + C980001_0.Progress.Lock; + + select + C980001_0.Hold_Up.Lock; -- Adjust will unlock + + Wait_Your_Turn; -- abortable part is stuck in Adjust + Check_Adjust_Conditions; + + then abort + declare + Object1 : C980001_0.Sticks_In_Adjust; + Object2 : C980001_0.Sticks_In_Adjust; + begin + Object1 := Object2; + delay Impdef.Minimum_Task_Switch; + if Report.Ident_Int( Object2.Item ) + /= Report.Ident_Int( Object1.Item ) then + Report.Failed("Optimization foil 1 caused failure"); + end if; + C980001_0.Fail_And_Clear("Adjust test executed beyond expected region"); + end; + end select; + + C980001_0.Progress.Lock; + + select + C980001_0.Hold_Up.Lock; -- Finalize will unlock + + Wait_Your_Turn; -- abortable part is stuck in Finalize + Check_Finalize_Conditions; + + then abort + declare + Object1 : C980001_0.Sticks_In_Finalize; + Object2 : C980001_0.Sticks_In_Finalize; + begin + Object1 := Object2; -- cause a finalize call + delay Impdef.Minimum_Task_Switch; + if Report.Ident_Int( Object2.Item ) + /= Report.Ident_Int( Object1.Item ) then + Report.Failed("Optimization foil 2 caused failure"); + end if; + C980001_0.Fail_And_Clear( + "Finalize test executed beyond expected region"); + end; + end select; + + Report.Result; + +exception + when others => C980001_0.Fail_And_Clear("Exception in main"); + Report.Result; +end C980001; diff --git a/gcc/testsuite/ada/acats/tests/c9/c980002.a b/gcc/testsuite/ada/acats/tests/c9/c980002.a new file mode 100644 index 000000000..f2b9c5247 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c980002.a @@ -0,0 +1,165 @@ +-- C980002.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- OBJECTIVE: +-- Check that aborts are deferred during protected actions. +-- +-- TEST DESCRIPTION: +-- This test uses an asynchronous transfer of control to attempt +-- to abort a protected operation. The protected operation +-- includes several requeues to check that the requeue does not +-- allow the abort to occur. +-- +-- +-- CHANGE HISTORY: +-- 30 OCT 95 SAIC ACVC 2.1 +-- +--! + +with Report; +procedure C980002 is + + Max_Checkpoints : constant := 7; + type Checkpoint_ID is range 1..Max_Checkpoints; + type Points_Array is array (Checkpoint_ID) of Boolean; +begin + Report.Test ("C980002", + "Check that aborts are deferred during a protected action" & + " including requeues"); + + declare -- test encapsulation + + protected Checkpoint is + procedure Got_Here (Id : Checkpoint_ID); + function Results return Points_Array; + private + Reached_Points : Points_Array := (others => False); + end Checkpoint; + + protected body Checkpoint is + procedure Got_Here (Id : Checkpoint_ID) is + begin + Reached_Points (Id) := True; + end Got_Here; + + function Results return Points_Array is + begin + return Reached_Points; + end Results; + end Checkpoint; + + + protected Start_Here is + entry AST_Waits_Here; + entry Start_PO; + private + Open : Boolean := False; + entry First_Stop; + end Start_Here; + + protected Middle_PO is + entry Stop_1; + entry Stop_2; + end Middle_PO; + + protected Final_PO is + entry Final_Stop; + end Final_PO; + + + protected body Start_Here is + entry AST_Waits_Here when Open is + begin + null; + end AST_Waits_Here; + + entry Start_PO when True is + begin + Open := True; + Checkpoint.Got_Here (1); + requeue First_Stop; + end Start_PO; + + -- make sure the AST has been accepted before continuing + entry First_Stop when AST_Waits_Here'Count = 0 is + begin + Checkpoint.Got_Here (2); + requeue Middle_PO.Stop_1; + end First_Stop; + end Start_Here; + + protected body Middle_PO is + entry Stop_1 when True is + begin + Checkpoint.Got_Here (3); + requeue Stop_2; + end Stop_1; + + entry Stop_2 when True is + begin + Checkpoint.Got_Here (4); + requeue Final_PO.Final_Stop; + end Stop_2; + end Middle_PO; + + protected body Final_PO is + entry Final_Stop when True is + begin + Checkpoint.Got_Here (5); + end Final_Stop; + end Final_PO; + + + begin -- test encapsulation + select + Start_Here.AST_Waits_Here; + Checkpoint.Got_Here (6); + then abort + Start_Here.Start_PO; + delay 0.0; -- abort completion point + Checkpoint.Got_Here (7); + end select; + + Check_The_Results: declare + Chk : constant Points_Array := Checkpoint.Results; + Expected : constant Points_Array := (1..6 => True, + 7 => False); + begin + for I in Checkpoint_ID loop + if Chk (I) /= Expected (I) then + Report.Failed ("checkpoint error" & + Checkpoint_ID'Image (I) & + " actual is " & + Boolean'Image (Chk(I))); + end if; + end loop; + end Check_The_Results; + exception + when others => + Report.Failed ("unexpected exception"); + end; -- test encapsulation + + Report.Result; +end C980002; diff --git a/gcc/testsuite/ada/acats/tests/c9/c980003.a b/gcc/testsuite/ada/acats/tests/c9/c980003.a new file mode 100644 index 000000000..dd69fc7ee --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c980003.a @@ -0,0 +1,294 @@ +-- C980003.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- +-- TEST OBJECTIVE: +-- Check that aborts are deferred during the execution of an +-- Initialize procedure (as the last step of the default +-- initialization of a controlled object), during the execution +-- of a Finalize procedure (as part of the finalization of a +-- controlled object), and during an assignment operation to an +-- object with a controlled part. +-- +-- TEST DESCRIPTION: +-- A controlled type is created with Initialize, Adjust, and +-- Finalize operations. These operations note in a protected +-- object when the operation starts and completes. This change +-- in state of the protected object will open the barrier for +-- the entry in the protected object. +-- The test contains declarations of objects of the controlled +-- type. An asynchronous select is used to attempt to abort +-- the operations on the controlled type. The asynchronous select +-- makes use of the state change to the protected object to +-- trigger the abort. +-- +-- +-- CHANGE HISTORY: +-- 11 Jan 96 SAIC Initial Release for 2.1 +-- 5 May 96 SAIC Incorporated Reviewer comments. +-- 10 Oct 96 SAIC Addressed issue where assignment statement +-- can be 2 assignment operations. +-- +--! + +with Ada.Finalization; +package C980003_0 is + Verbose : constant Boolean := False; + + -- the following flag is set true whenever the + -- Initialize operation is called. + Init_Occurred : Boolean; + + type Is_Controlled is new Ada.Finalization.Controlled with + record + Id : Integer; + end record; + + procedure Initialize (Object : in out Is_Controlled); + procedure Finalize (Object : in out Is_Controlled); + procedure Adjust (Object : in out Is_Controlled); + + type States is (Unknown, + Start_Init, Finished_Init, + Start_Adjust, Finished_Adjust, + Start_Final, Finished_Final); + + protected State_Manager is + procedure Reset; + procedure Set (New_State : States); + function Current return States; + entry Wait_For_Change; + private + Current_State : States := Unknown; + Changed : Boolean := False; + end State_Manager; + +end C980003_0; + + +with Report; +with ImpDef; +package body C980003_0 is + protected body State_Manager is + procedure Reset is + begin + Current_State := Unknown; + Changed := False; + end Reset; + + procedure Set (New_State : States) is + begin + Changed := True; + Current_State := New_State; + end Set; + + function Current return States is + begin + return Current_State; + end Current; + + entry Wait_For_Change when Changed is + begin + Changed := False; + end Wait_For_Change; + end State_Manager; + + procedure Initialize (Object : in out Is_Controlled) is + begin + if Verbose then + Report.Comment ("starting initialize"); + end if; + State_Manager.Set (Start_Init); + if Verbose then + Report.Comment ("in initialize"); + end if; + delay ImpDef.Switch_To_New_Task; -- tempting place for abort + State_Manager.Set (Finished_Init); + if Verbose then + Report.Comment ("finished initialize"); + end if; + Init_Occurred := True; + end Initialize; + + procedure Finalize (Object : in out Is_Controlled) is + begin + if Verbose then + Report.Comment ("starting finalize"); + end if; + State_Manager.Set (Start_Final); + if Verbose then + Report.Comment ("in finalize"); + end if; + delay ImpDef.Switch_To_New_Task; -- tempting place for abort + State_Manager.Set (Finished_Final); + if Verbose then + Report.Comment ("finished finalize"); + end if; + end Finalize; + + procedure Adjust (Object : in out Is_Controlled) is + begin + if Verbose then + Report.Comment ("starting adjust"); + end if; + State_Manager.Set (Start_Adjust); + if Verbose then + Report.Comment ("in adjust"); + end if; + delay ImpDef.Switch_To_New_Task; -- tempting place for abort + State_Manager.Set (Finished_Adjust); + if Verbose then + Report.Comment ("finished adjust"); + end if; + end Adjust; +end C980003_0; + + +with Report; +with ImpDef; +with C980003_0; use C980003_0; +with Ada.Unchecked_Deallocation; +procedure C980003 is + + procedure Check_State (Should_Be : States; + Msg : String) is + Cur : States := State_Manager.Current; + begin + if Cur /= Should_Be then + Report.Failed (Msg); + Report.Comment ("expected: " & States'Image (Should_Be) & + " found: " & States'Image (Cur)); + elsif Verbose then + Report.Comment ("passed: " & Msg); + end if; + end Check_State; + +begin + + Report.Test ("C980003", "Check that aborts are deferred during" & + " initialization, finalization, and assignment" & + " operations on controlled objects"); + + Check_State (Unknown, "initial condition"); + + -- check that initialization and finalization take place + Init_Occurred := False; + select + State_Manager.Wait_For_Change; + then abort + declare + My_Controlled_Obj : Is_Controlled; + begin + delay 0.0; -- abort completion point + Report.Failed ("state change did not occur"); + end; + end select; + if not Init_Occurred then + Report.Failed ("Initialize did not complete"); + end if; + Check_State (Finished_Final, "init/final for declared item"); + + -- check adjust + State_Manager.Reset; + declare + Source, Dest : Is_Controlled; + begin + Check_State (Finished_Init, "adjust initial state"); + Source.Id := 3; + Dest.Id := 4; + State_Manager.Reset; -- so we will wait for change + select + State_Manager.Wait_For_Change; + then abort + Dest := Source; + end select; + + -- there are two implementation methods for the + -- assignment statement: + -- 1. no temporary was used in the assignment statement + -- thus the entire + -- assignment statement is abort deferred. + -- 2. a temporary was used in the assignment statement so + -- there are two assignment operations. An abort may + -- occur between the assignment operations + -- Various optimizations are allowed by 7.6 that can affect + -- how many times Adjust and Finalize are called. + -- Depending upon the implementation, the state can be either + -- Finished_Adjust or Finished_Finalize. If it is any other + -- state then the abort took place at the wrong time. + + case State_Manager.Current is + when Finished_Adjust => + if Verbose then + Report.Comment ("assignment aborted after adjust"); + end if; + when Finished_Final => + if Verbose then + Report.Comment ("assignment aborted after finalize"); + end if; + when Start_Adjust => + Report.Failed ("assignment aborted in adjust"); + when Start_Final => + Report.Failed ("assignment aborted in finalize"); + when Start_Init => + Report.Failed ("assignment aborted in initialize"); + when Finished_Init => + Report.Failed ("assignment aborted after initialize"); + when Unknown => + Report.Failed ("assignment aborted in unknown state"); + end case; + + + if Dest.Id /= 3 then + if Verbose then + Report.Comment ("assignment not performed"); + end if; + end if; + end; + + + -- check dynamically allocated objects + State_Manager.Reset; + declare + type Pointer_Type is access Is_Controlled; + procedure Free is new Ada.Unchecked_Deallocation ( + Is_Controlled, Pointer_Type); + Ptr : Pointer_Type; + begin + -- make sure initialize is done when object is allocated + Ptr := new Is_Controlled; + Check_State (Finished_Init, "init when item allocated"); + -- now try aborting the finalize + State_Manager.Reset; + select + State_Manager.Wait_For_Change; + then abort + Free (Ptr); + end select; + Check_State (Finished_Final, "finalization in dealloc"); + end; + + Report.Result; + +end C980003; diff --git a/gcc/testsuite/ada/acats/tests/c9/c99004a.ada b/gcc/testsuite/ada/acats/tests/c9/c99004a.ada new file mode 100644 index 000000000..8774314d5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c99004a.ada @@ -0,0 +1,166 @@ +-- C99004A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE PREFIX OF 'TERMINATED AND 'CALLABLE CAN BE A +-- FUNCTION CALL RETURNING AN OBJECT HAVING A TASK TYPE. + +-- NOTE: SEE TEST C38202A FOR CHECKS INVOLVING PREFIXES WHICH ARE +-- ACCESS TYPES DENOTING TASK TYPES OR WHICH ARE FUNCTIONS +-- RETURNING ACCESS TYPES DENOTING TASK TYPES. + +-- HISTORY: +-- RJW 09/16/86 CREATED ORIGINAL TEST. +-- DHH 10/15/87 CORRECTED HEADER COMMENTS. + +with Impdef; +WITH REPORT; USE REPORT; +PROCEDURE C99004A IS + + TYPE ENUM IS (A, B, C, D); + + EARRAY : ARRAY (ENUM) OF STRING (1 .. 17) := + (A => "BEFORE ACTIVATION", + B => "DURING ACTIVATION", + C => "DURING EXECUTION ", + D => "AFTER TERMINATION" ); + + FUNCTION CHECK (S : STRING; CALL, B1, TERM, B2 : BOOLEAN; + E : ENUM) RETURN BOOLEAN IS + BEGIN + IF CALL /= B1 THEN + FAILED ( "INCORRECT VALUE FOR " & S & "'CALLABLE " & + EARRAY (E) & " OF TASK" ); + END IF; + + IF TERM /= B2 THEN + FAILED ( "INCORRECT VALUE FOR " & S & "'TERMINATED " & + EARRAY (E) & " OF TASK" ); + END IF; + + RETURN IDENT_BOOL (TRUE); + END CHECK; + + +BEGIN + TEST ( "C99004A", "CHECK THAT THE PREFIX OF 'TERMINATED AND " & + "'CALLABLE CAN BE A FUNCTION CALL RETURNING " & + "AN OBJECT HAVING A TASK TYPE" ); + + DECLARE + + TASK TYPE TT IS + ENTRY E; + END TT; + + PACKAGE PKG1 IS + T1 : TT; + END PKG1; + + FUNCTION F RETURN TT IS + BEGIN + RETURN PKG1.T1; + END F; + + PACKAGE PKG2 IS + A1 : BOOLEAN := CHECK ("F", F'CALLABLE, TRUE, + F'TERMINATED, FALSE, A); + END PKG2; + + TASK MAIN_TASK IS + ENTRY E (INTEGER RANGE 1 .. 2); + END MAIN_TASK; + + TASK BODY TT IS + B1 : BOOLEAN := CHECK ("F", F'CALLABLE, TRUE, + F'TERMINATED, FALSE, B); + C1 : BOOLEAN; + BEGIN + C1 := CHECK ("F", F'CALLABLE, TRUE, + F'TERMINATED, FALSE, C); + MAIN_TASK.E (1); + MAIN_TASK.E (2); + END TT; + + PACKAGE BODY PKG1 IS + BEGIN + NULL; + END; + + TASK BODY MAIN_TASK IS + D1 : BOOLEAN; + BEGIN + ACCEPT E (1); + ABORT PKG1.T1; + DELAY 5.0 * Impdef.One_Long_Second; + D1 := CHECK ("F", F'CALLABLE, FALSE, + F'TERMINATED, TRUE, D); + END MAIN_TASK; + + BEGIN + NULL; + END; + + DECLARE + + TASK TYPE TT IS + ENTRY E; + END TT; + + T2 : TT; + + A2 : BOOLEAN := CHECK ("T2", T2'CALLABLE, TRUE, + T2'TERMINATED, FALSE, A); + + TASK MAIN_TASK IS + ENTRY E (INTEGER RANGE 1 .. 2); + END MAIN_TASK; + + TASK BODY TT IS + B2 : BOOLEAN := CHECK ("T2", T2'CALLABLE, TRUE, + T2'TERMINATED, FALSE, B); + C2 : BOOLEAN; + BEGIN + C2 := CHECK ("T2", T2'CALLABLE, TRUE, + T2'TERMINATED, FALSE, C); + MAIN_TASK.E (1); + MAIN_TASK.E (2); + END TT; + + TASK BODY MAIN_TASK IS + D2 : BOOLEAN; + BEGIN + ACCEPT E (1); + ABORT T2; + DELAY 5.0 * Impdef.One_Long_Second; + D2 := CHECK ("T2", T2'CALLABLE, FALSE, + T2'TERMINATED, TRUE, D); + END MAIN_TASK; + + BEGIN + NULL; + END; + + RESULT; +END C99004A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c99005a.ada b/gcc/testsuite/ada/acats/tests/c9/c99005a.ada new file mode 100644 index 000000000..f3bcbaa6e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c99005a.ada @@ -0,0 +1,183 @@ +-- C99005A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT THE ATTRIBUTE 'COUNT RETURNS THE CORRECT VALUE. + +-- HISTORY: +-- DHH 03/24/88 CREATED ORIGINAL TEST. + +with Impdef; +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE C99005A IS + +BEGIN + + TEST("C99005A", "CHECK THAT THE ATTRIBUTE 'COUNT RETURNS THE " & + "CORRECT VALUE"); + + DECLARE + TASK A IS + END A; + + TASK B IS + END B; + + TASK C IS + END C; + + TASK D IS + END D; + + TASK E IS + END E; + + TASK F IS + END F; + + TASK G IS + END G; + + TASK H IS + END H; + + TASK I IS + END I; + + TASK J IS + END J; + + TASK T IS + ENTRY WAIT; + END T; + + TASK CHOICE IS + ENTRY RETURN_CALL; + ENTRY E2; + ENTRY E1; + END CHOICE; + + TASK BODY A IS + BEGIN + CHOICE.E1; + END A; + + TASK BODY B IS + BEGIN + CHOICE.E1; + END B; + + TASK BODY C IS + BEGIN + CHOICE.E1; + END C; + + TASK BODY D IS + BEGIN + CHOICE.E1; + END D; + + TASK BODY E IS + BEGIN + CHOICE.E1; + END E; + + TASK BODY F IS + BEGIN + CHOICE.E2; + END F; + + TASK BODY G IS + BEGIN + CHOICE.E2; + END G; + + TASK BODY H IS + BEGIN + CHOICE.E2; + END H; + + TASK BODY I IS + BEGIN + CHOICE.E2; + END I; + + TASK BODY J IS + BEGIN + CHOICE.E2; + END J; + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT WAIT DO + DELAY 1.0 * Impdef.One_Second; + END WAIT; + CHOICE.RETURN_CALL; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + + TASK BODY CHOICE IS + BEGIN + WHILE E1'COUNT + E2'COUNT < 10 LOOP + T.WAIT; + ACCEPT RETURN_CALL; + END LOOP; + + FOR I IN REVERSE 1 ..10 LOOP + SELECT + ACCEPT E2 DO + IF (E2'COUNT + E1'COUNT + 1) /= I THEN + FAILED("'COUNT NOT RETURNING " & + "CORRECT VALUE FOR LOOP" & + INTEGER'IMAGE(I) & "VALUE " & + INTEGER'IMAGE((E2'COUNT + + E1'COUNT + 1))); + END IF; + END E2; + OR + ACCEPT E1 DO + IF (E2'COUNT + E1'COUNT + 1) /= I THEN + FAILED("'COUNT NOT RETURNING " & + "CORRECT VALUE FOR LOOP" & + INTEGER'IMAGE(I) & "VALUE " & + INTEGER'IMAGE((E2'COUNT + + E1'COUNT + 1))); + END IF; + END E1; + END SELECT; + END LOOP; + END CHOICE; + + BEGIN + NULL; + END; + + RESULT; +END C99005A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a003a.ada b/gcc/testsuite/ada/acats/tests/c9/c9a003a.ada new file mode 100644 index 000000000..e8d7706cc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c9a003a.ada @@ -0,0 +1,105 @@ +-- C9A003A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT ABORTING A TERMINATED TASK DOES NOT CAUSE EXCEPTIONS. + + +-- RM 5/21/82 +-- SPS 11/21/82 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X + +with Impdef; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C9A003A IS + + -- THE TASK WILL HAVE HIGHER PRIORITY ( PRIORITY'LAST ) + +BEGIN + + + ------------------------------------------------------------------- + + + TEST ("C9A003A", "CHECK THAT ABORTING A TERMINATED TASK" & + " DOES NOT CAUSE EXCEPTIONS" ); + + + DECLARE + + + TASK TYPE T_TYPE IS + + + ENTRY E ; + + END T_TYPE ; + + + T_OBJECT1 : T_TYPE ; + + + TASK BODY T_TYPE IS + BUSY : BOOLEAN := FALSE ; + BEGIN + + NULL; + + END T_TYPE ; + + + BEGIN + + + IF NOT T_OBJECT1'TERMINATED THEN + DELAY 20.0 * Impdef.One_Second; + END IF; + + IF NOT T_OBJECT1'TERMINATED THEN + COMMENT( "TASK NOT YET TERMINATED (AFTER 20 S.)" ); + END IF; + + + BEGIN + ABORT T_OBJECT1 ; + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED (WHEN ABORTING A" & + " TERMINATED TASK)" ); + + END ; + + + END ; + + + ------------------------------------------------------------------- + + + + RESULT; + + +END C9A003A ; diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a004a.ada b/gcc/testsuite/ada/acats/tests/c9/c9a004a.ada new file mode 100644 index 000000000..124724379 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c9a004a.ada @@ -0,0 +1,108 @@ +-- C9A004A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT IF A TASK IS ABORTED BEFORE BEING ACTIVATED, THE TASK IS +-- TERMINATED. + + +-- RM 5/21/82 +-- SPS 11/21/82 +-- JBG 6/3/85 +-- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X + +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C9A004A IS + +BEGIN + + + ------------------------------------------------------------------- + + + TEST ("C9A004A", "CHECK THAT IF A TASK IS ABORTED" & + " BEFORE BEING ACTIVATED," & + " THE TASK IS TERMINATED" ); + + + DECLARE + + + TASK TYPE T_TYPE IS + + + ENTRY E ; + + END T_TYPE ; + + + T_OBJECT1 : T_TYPE ; + + + TASK BODY T_TYPE IS + BUSY : BOOLEAN := FALSE ; + BEGIN + + NULL; + + END T_TYPE ; + + + PACKAGE P IS + X : INTEGER := 0 ; + END P ; + + + PACKAGE BODY P IS + BEGIN + + IF T_OBJECT1'TERMINATED OR + NOT T_OBJECT1'CALLABLE + THEN + FAILED( "WRONG VALUES FOR ATTRIBUTES" ); + END IF; + + ABORT T_OBJECT1 ; -- ELABORATED BUT NOT YET ACTIVATED. + + END P ; + + + BEGIN + + + IF NOT T_OBJECT1'TERMINATED THEN + FAILED( "ABORTED (BEFORE ACTIVATION) TASK" & + " NOT TERMINATED" ); + END IF; + + EXCEPTION + + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + + END; + + RESULT; + +END C9A004A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a007a.ada b/gcc/testsuite/ada/acats/tests/c9/c9a007a.ada new file mode 100644 index 000000000..9339930a5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c9a007a.ada @@ -0,0 +1,293 @@ +-- C9A007A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TASK MAY ABORT A TASK IT DEPENDS ON. + + +-- RM 5/26/82 +-- RM 7/02/82 +-- SPS 11/21/82 +-- JBG 2/27/84 +-- JBG 3/8/84 +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. +-- EDS 08/04/98 ENSURE THAT ABORTED TASKS HAVE TIME TO EFFECT THEIR ABORTIONS. + +WITH IMPDEF; +WITH REPORT; USE REPORT; +WITH SYSTEM; USE SYSTEM; +PROCEDURE C9A007A IS + + TASK_NOT_ABORTED : BOOLEAN := FALSE; + TEST_VALID : BOOLEAN := TRUE ; + +BEGIN + + + ------------------------------------------------------------------- + + + TEST ( "C9A007A" , "CHECK THAT A TASK MAY ABORT A TASK" & + " IT DEPENDS ON" ); + + + DECLARE + + + TASK REGISTER IS + + + ENTRY BIRTHS_AND_DEATHS; + + ENTRY SYNC1; + ENTRY SYNC2; + + + END REGISTER; + + + TASK BODY REGISTER IS + + + TASK TYPE SECONDARY IS + + + ENTRY WAIT_INDEFINITELY; + + END SECONDARY; + + + TASK TYPE T_TYPE1 IS + + + ENTRY E; + + END T_TYPE1; + + + TASK TYPE T_TYPE2 IS + + + ENTRY E; + + END T_TYPE2; + + + T_OBJECT1 : T_TYPE1; + T_OBJECT2 : T_TYPE2; + + + TASK BODY SECONDARY IS + BEGIN + SYNC1; + ABORT T_OBJECT1; + DELAY 0.0; + TASK_NOT_ABORTED := TRUE; + END SECONDARY; + + + TASK BODY T_TYPE1 IS + + TYPE ACCESS_TO_TASK IS ACCESS SECONDARY; + + BEGIN + + + DECLARE + DEPENDENT_BY_ACCESS : ACCESS_TO_TASK := + NEW SECONDARY ; + BEGIN + NULL; + END; + + + BIRTHS_AND_DEATHS; + -- DURING THIS SUSPENSION + -- MOST OF THE TASKS + -- ARE ABORTED (FIRST + -- TASK #1 -- T_OBJECT1 -- + -- THEN #2 ). + + + TASK_NOT_ABORTED := TRUE; + + + END T_TYPE1; + + + TASK BODY T_TYPE2 IS + + TASK INNER_TASK IS + + + ENTRY WAIT_INDEFINITELY; + + END INNER_TASK; + + TASK BODY INNER_TASK IS + BEGIN + SYNC2; + ABORT T_OBJECT2; + DELAY 0.0; + TASK_NOT_ABORTED := TRUE; + END INNER_TASK; + + BEGIN + + + BIRTHS_AND_DEATHS; + -- DURING THIS SUSPENSION + -- MOST OF THE TASKS + -- ARE ABORTED (FIRST + -- TASK #1 -- T_OBJECT1 -- + -- THEN #2 ). + + + TASK_NOT_ABORTED := TRUE; + + + END T_TYPE2; + + + BEGIN + + DECLARE + OLD_COUNT : INTEGER := 0; + BEGIN + + + FOR I IN 1..5 LOOP + EXIT WHEN BIRTHS_AND_DEATHS'COUNT = 2; + DELAY 10.0 * Impdef.One_Second; + END LOOP; + + OLD_COUNT := BIRTHS_AND_DEATHS'COUNT; + + IF OLD_COUNT = 2 THEN + + ACCEPT SYNC1; -- ALLOWING ABORT#1 + + DELAY IMPDEF.CLEAR_READY_QUEUE; + + -- CHECK THAT #1 WAS ABORTED - 3 WAYS: + + BEGIN + T_OBJECT1.E; + FAILED( "T_OBJECT1.E DID NOT RAISE" & + " TASKING_ERROR" ); + EXCEPTION + + WHEN TASKING_ERROR => + NULL; + + WHEN OTHERS => + FAILED("OTHER EXCEPTION RAISED - 1"); + + END; + + IF T_OBJECT1'CALLABLE THEN + FAILED( "T_OBJECT1'CALLABLE = TRUE" ); + END IF; + + IF OLD_COUNT - BIRTHS_AND_DEATHS'COUNT /= 1 + THEN + FAILED( "TASK#1 NOT REMOVED FROM QUEUE" ); + END IF; + + + OLD_COUNT := BIRTHS_AND_DEATHS'COUNT; + + + ACCEPT SYNC2; -- ALLOWING ABORT#2 + + DELAY IMPDEF.CLEAR_READY_QUEUE; + + -- CHECK THAT #2 WAS ABORTED - 3 WAYS: + + BEGIN + T_OBJECT2.E; + FAILED( "T_OBJECT2.E DID NOT RAISE" & + " TASKING_ERROR" ); + EXCEPTION + + WHEN TASKING_ERROR => + NULL; + + WHEN OTHERS => + FAILED("OTHER EXCEPTION RAISED - 2"); + + END; + + IF T_OBJECT2'CALLABLE THEN + FAILED( "T_OBJECT2'CALLABLE = TRUE" ); + END IF; + + IF OLD_COUNT - BIRTHS_AND_DEATHS'COUNT /= 1 + THEN + FAILED( "TASK#2 NOT REMOVED FROM QUEUE" ); + END IF; + + + IF BIRTHS_AND_DEATHS'COUNT /= 0 THEN + FAILED( "SOME TASKS STILL QUEUED" ); + END IF; + + + ELSE + + COMMENT( "LINEUP NOT COMPLETE (AFTER 50 S.)" ); + TEST_VALID := FALSE; + + END IF; + + + END; + + + WHILE BIRTHS_AND_DEATHS'COUNT > 0 LOOP + ACCEPT BIRTHS_AND_DEATHS; + END LOOP; + + + END REGISTER; + + + BEGIN + + NULL; + + END; + + + ------------------------------------------------------------------- + + + IF TEST_VALID AND TASK_NOT_ABORTED THEN + FAILED( "SOME TASKS NOT ABORTED" ); + END IF; + + + RESULT; + + +END C9A007A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a009a.ada b/gcc/testsuite/ada/acats/tests/c9/c9a009a.ada new file mode 100644 index 000000000..ba3b0845d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c9a009a.ada @@ -0,0 +1,117 @@ +-- C9A009A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- TEST ABORT DURING RENDEZVOUS + +-- CALLING TASK IN RENDEVOUS IS NAMED IN ABORT STATEMENT. + +-- JEAN-PIERRE ROSEN 09 MARCH 1984 +-- JBG 6/1/84 +-- JWC 6/28/85 RENAMED FROM C9A009D-B.ADA + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE C9A009A IS + +BEGIN + + TEST("C9A009A", "CALLING TASK IS ABORTED DIRECTLY"); + + DECLARE + -- T1 CALLS T2, WHICH ABORTS T1 WHILE IN RENDEVOUS + + T2_CONTINUED : BOOLEAN := FALSE; + + TASK CONTINUED IS + ENTRY GET (T2_CONTINUED : OUT BOOLEAN); + ENTRY PUT (T2_CONTINUED : IN BOOLEAN); + END CONTINUED; + + TASK BODY CONTINUED IS + CONTINUED : BOOLEAN := FALSE; + BEGIN + LOOP + SELECT + ACCEPT GET (T2_CONTINUED : OUT BOOLEAN) DO + T2_CONTINUED := CONTINUED; + END GET; + OR + ACCEPT PUT (T2_CONTINUED : IN BOOLEAN) DO + CONTINUED := T2_CONTINUED; + END PUT; + OR + TERMINATE; + END SELECT; + END LOOP; + END CONTINUED; + + BEGIN -- THIS BLOCK WILL MAKE SURE T2 IS TERMINATED, AND SO, + -- T2_CONTINUED IS ASSIGNED A VALUE IF T2 CONTINUES + -- EXECUTION CORRECTLY. + + DECLARE + + TASK T1; + + TASK T2 IS + ENTRY E1; + END T2; + + TASK BODY T1 IS + BEGIN + T2.E1; + FAILED ("T1 NOT ABORTED"); + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED IN T1"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - T1"); + END T1; + + TASK BODY T2 IS + BEGIN + ACCEPT E1 DO + ABORT T1; + ABORT T1; + ABORT T1; -- WHY NOT? + IF T1'TERMINATED THEN + FAILED ("T1 PREMATURELY TERMINATED"); + END IF; + END E1; + CONTINUED.PUT (T2_CONTINUED => TRUE); + END T2; + BEGIN + NULL; + END; + -- T2 NOW TERMINATED + CONTINUED.GET (T2_CONTINUED); + IF NOT T2_CONTINUED THEN + FAILED ("WHEN CALLER WAS ABORTED IN RENDEVOUS, CALLED " & + "TASK DID NOT CONTINUE"); + END IF; + END; + + RESULT; + +END C9A009A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a009c.ada b/gcc/testsuite/ada/acats/tests/c9/c9a009c.ada new file mode 100644 index 000000000..89b7390b1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c9a009c.ada @@ -0,0 +1,95 @@ +-- C9A009C.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- TEST ABORT DURING RENDEZVOUS + +-- THE CALLING TASK IN THE RENDEVOUS IS DEPENDENT ON THE ABORTED TASK, +-- SO THE DEPENDENT TASK IS INDIRECTLY ABORTED WHILE IN A RENDEVOUS; +-- NEITHER THE CALLING TASK NOR ITS MASTER CAN BE TERMINATED WHILE THE +-- RENDEVOUS CONTINUES. + +-- JEAN-PIERRE ROSEN 09 MARCH 1984 +-- JBG 6/1/84 + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE C9A009C IS + +BEGIN + + TEST("C9A009C", "DEPENDENT TASK IN RENDEVOUS WHEN MASTER IS " & + "ABORTED"); + + DECLARE + -- T2 CONTAINS DEPENDENT TASK T3 WHICH CALLS T1. + -- T1 ABORTS T2 WHILE IN RENDEVOUS WITH T3. + + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + + TASK T2; + + TASK BODY T2 IS + TASK T3; + TASK BODY T3 IS + BEGIN + T1.E1; + FAILED ("T3 NOT ABORTED"); + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR IN T3"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION IN T3"); + END; + BEGIN -- T3 ACTIVATED NOW + NULL; + END T2; + + BEGIN -- T1 + ACCEPT E1 DO + ABORT T2; + ABORT T2; + ABORT T2; -- WHY NOT? + IF T2'TERMINATED THEN + FAILED ("T2 TERMINATED PREMATURELY"); + END IF; + END E1; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR IN T1 BECAUSE CALLING TASK "& + "WAS ABORTED"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION - T1"); + END T1; + + BEGIN + NULL; + END; + + RESULT; + +END C9A009C; diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a009f.ada b/gcc/testsuite/ada/acats/tests/c9/c9a009f.ada new file mode 100644 index 000000000..e100a9f0c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c9a009f.ada @@ -0,0 +1,88 @@ +-- C9A009F.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TASK ABORTED DURING AN ENTRY CALL IS NOT TERMINATED +-- BEFORE THE END OF THE RENDEZVOUS. + +-- JEAN-PIERRE ROSEN 16-MAR-1984 +-- JBG 6/1/84 +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +WITH REPORT,SYSTEM; +USE REPORT,SYSTEM; +PROCEDURE C9A009F IS + + + TASK BLOCKING IS + ENTRY START; + ENTRY STOP; + ENTRY RESTART; + ENTRY NO_CALL; + END BLOCKING; + + TASK BODY BLOCKING IS + BEGIN + SELECT + ACCEPT STOP DO + ACCEPT START; + ACCEPT RESTART; + END; + OR TERMINATE; + END SELECT; + END; + +BEGIN + + TEST("C9A009F", "ABORTED TASK NOT TERMINATED BEFORE END OF " & + "RENDEVOUS"); + + DECLARE -- T1 ABORTED WHILE IN RENDEVOUS WITH BLOCKING. + + TASK T1 IS + END T1; + TASK BODY T1 IS + BEGIN + BLOCKING.STOP; + FAILED ("T1 NOT ABORTED"); + END; + + BEGIN + BLOCKING.START; -- ALLOWS T1 TO ENTER RENDEVOUS + + ABORT T1; + + IF T1'CALLABLE THEN + FAILED("T1 STILL CALLABLE - 1"); + END IF; + + IF T1'TERMINATED THEN -- T1 STILL IN RENDEVOUS + FAILED("T1 PREMATURELY TERMINATED - 1"); + END IF; + + BLOCKING.RESTART; + END; + + RESULT; + +END C9A009F; diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a009g.ada b/gcc/testsuite/ada/acats/tests/c9/c9a009g.ada new file mode 100644 index 000000000..7dea8a4ba --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c9a009g.ada @@ -0,0 +1,95 @@ +-- C9A009G.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A MASTER ABORTED WITH SUBTASKS IN AN ENTRY CALL BECOMES +-- COMPLETED, BUT NOT TERMINATED, BEFORE THE END OF THE RENDEZVOUS. + +-- JEAN-PIERRE ROSEN 16-MAR-1984 +-- JBG 6/1/84 +-- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + +WITH REPORT,SYSTEM; +USE REPORT,SYSTEM; +PROCEDURE C9A009G IS + + + TASK BLOCKING IS + ENTRY START; + ENTRY STOP; + ENTRY RESTART; + ENTRY NO_CALL; + END BLOCKING; + + TASK BODY BLOCKING IS + BEGIN + SELECT + ACCEPT STOP DO + ACCEPT START; + ACCEPT RESTART; + END; + OR TERMINATE; + END SELECT; + END; + +BEGIN + + TEST("C9A009G", "MASTER COMPLETED BUT NOT TERMINATED"); + + DECLARE -- T1 ABORTED WHILE DEPENDENT TASK IN RENDEVOUS 9C? + + TASK T1 IS + ENTRY LOCK; + END T1; + + TASK BODY T1 IS + TASK T2; + + TASK BODY T2 IS + BEGIN + BLOCKING.STOP; + FAILED ("T2 NOT ABORTED"); + END; + BEGIN + BLOCKING.NO_CALL; -- WILL DEADLOCK UNTIL ABORT + END T1; + + BEGIN + BLOCKING.START; + ABORT T1; + + IF T1'CALLABLE THEN + FAILED("T1 STILL CALLABLE - 2"); + END IF; + + IF T1'TERMINATED THEN -- T1'S DEPENDENT TASK, T2, STILL IN + -- RENDEVOUS + FAILED("T1 PREMATURELY TERMINATED - 2"); + END IF; + + BLOCKING.RESTART; + END; + + RESULT; + +END C9A009G; diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a009h.ada b/gcc/testsuite/ada/acats/tests/c9/c9a009h.ada new file mode 100644 index 000000000..914fce187 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c9a009h.ada @@ -0,0 +1,77 @@ +-- C9A009H.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- CHECK THAT A TASK ABORTED DURING A RENDEVOUS IS NEITHER CALLABLE NOR +-- TERMINATED BEFORE THE END OF THE RENDEVOUS. + +-- J.P ROSEN, ADA PROJECT, NYU +-- JBG 6/1/84 + +WITH REPORT; USE REPORT; +PROCEDURE C9A009H IS +BEGIN + TEST ("C9A009H", "TASK ABORTED IN RENDEVOUS IS NOT CALLABLE OR " & + "TERMINATED"); + + DECLARE + + TASK T1 IS + ENTRY E1; + END T1; + + TASK T2 IS + END T2; + + TASK BODY T2 IS + BEGIN + T1.E1; + FAILED ("T2 NOT ABORTED"); + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED IN ABORTED TASK"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED"); + END T2; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 DO + ABORT T2; + IF T2'CALLABLE THEN + FAILED ("T2 STILL CALLABLE"); + END IF; + + IF T2'TERMINATED THEN + FAILED ("T2 TERMINATED"); + END IF; + END E1; + END T1; + + BEGIN + NULL; + END; + + RESULT; + +END C9A009H; diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a010a.ada b/gcc/testsuite/ada/acats/tests/c9/c9a010a.ada new file mode 100644 index 000000000..553b72d80 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c9a010a.ada @@ -0,0 +1,89 @@ +-- C9A010A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- TEST ABORT DURING RENDEZVOUS + +-- ABORTING AN ABNORMAL (NOT YET TERMINATED) TASK. + +-- JEAN-PIERRE ROSEN 09 MARCH 1984 +-- JBG 6/1/84 +-- JWC 6/28/85 RENAMED FROM C9A009E-B.ADA +-- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE C9A010A IS + +BEGIN + + TEST("C9A010A", "ABORTING AN ABNORMAL TASK"); + + DECLARE + -- T1 CALLS T2. WHILE IN RENDEVOUS, T2 ABORTS T1 AND WAITS FOR A + -- CALL FROM THE MAIN PROGRAM. WHEN THE CALL IS ACCEPTED, THE MAIN + -- PROGRAM AGAIN ABORTS T1, WHICH IS NOW ABNORMAL, SINCE T1 HAS NOT + -- YET COMPLETED ITS RENDEVOUS WITH T2. + + TASK T1 IS + END T1; + + TASK T2 IS + ENTRY E1; + ENTRY E2; + END T2; + + TASK BODY T1 IS + BEGIN + T2.E1; + FAILED("T1 NOT ABORTED"); + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR IN T1"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION IN T1"); + END T1; + + TASK BODY T2 IS + BEGIN + ACCEPT E1 DO + ABORT T1; + ACCEPT E2; -- NOTE CALLER REMAINS IN RENDEVOUS + ACCEPT E2; -- UNTIL TWO ENTRY CALLS ACCEPTED + END E1; + END T2; + BEGIN + T2.E2; -- ONLY ACCEPTED AFTER T1 HAS BEEN ABORTED. + ABORT T1; -- T1 IS ABNORMAL BECAUSE IT IS STILL IN RENDEVOUS. + IF T1'CALLABLE THEN + FAILED ("T1 CALLABLE AFTER BEING ABORTED"); + END IF; + IF T1'TERMINATED THEN + FAILED ("T1 TERMINATED ALTHOUGH IN RENDEVOUS"); + END IF; + T2.E2; -- T1'S RENDEVOUS CAN NOW COMPLETE; T1 CAN TERMINATE. + END; + + RESULT; + +END C9A010A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a011a.ada b/gcc/testsuite/ada/acats/tests/c9/c9a011a.ada new file mode 100644 index 000000000..1d415b07b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c9a011a.ada @@ -0,0 +1,71 @@ +-- C9A011A.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT IF A CALLED TASK IS ABORTED WHILE IN RENDEZVOUS, THEN +-- "TASKING_ERROR" IS RAISED IN THE CALLING TASK. + +-- HISTORY: +-- DHH 03/28/88 CREATED ORIGINAL TEST. + +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE C9A011A IS + + TASK TYPE CHOICE IS + ENTRY E1; + END CHOICE; + + T : CHOICE; + + TASK BODY CHOICE IS + X : INTEGER; + BEGIN + ACCEPT E1 DO + X := IDENT_INT(3); + IF EQUAL(X,X) THEN + ABORT CHOICE; + END IF; + END E1; + END CHOICE; + +BEGIN + + TEST("C9A011A", "CHECK THAT IF A CALLED TASK IS ABORTED WHILE " & + "IN RENDEZVOUS, THEN ""TASKING_ERROR"" IS " & + "RAISED IN THE CALLING TASK"); + + T.E1; + FAILED("EXCEPTION NOT RAISED ON ABORT"); + + RESULT; + +EXCEPTION + WHEN TASKING_ERROR => + RESULT; + + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED ON ABORT"); + RESULT; +END C9A011A; diff --git a/gcc/testsuite/ada/acats/tests/c9/c9a011b.ada b/gcc/testsuite/ada/acats/tests/c9/c9a011b.ada new file mode 100644 index 000000000..fe1ba1649 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c9/c9a011b.ada @@ -0,0 +1,102 @@ +-- C9A011B.ADA + +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE +-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A +-- PARTICULAR PURPOSE OF SAID MATERIAL. +--* +-- OBJECTIVE: +-- CHECK THAT "TASKING_ERROR" IS RAISED BY A TIMED ENTRY CALL IF +-- THE CALLED TASK IS ABORTED BEFORE THE DELAY EXPIRES BUT NOT +-- WHEN THE CALL IS FIRST EXECUTED. + +-- HISTORY: +-- DHH 06/14/88 CREATED ORIGINAL TEST. + +with Impdef; +WITH SYSTEM; USE SYSTEM; +WITH REPORT; USE REPORT; +PROCEDURE C9A011B IS + + TASK TIMED_ENTRY IS + ENTRY WAIT_AROUND; + END TIMED_ENTRY; + + TASK OWNER IS + ENTRY START; + ENTRY SELF_ABORT; + END OWNER; + + TASK BODY TIMED_ENTRY IS + BEGIN + SELECT + OWNER.SELF_ABORT; + OR + DELAY 60.0 * Impdef.One_Second; + END SELECT; + FAILED("NO EXCEPTION RAISED"); + + ACCEPT WAIT_AROUND; + EXCEPTION + WHEN TASKING_ERROR => + ACCEPT WAIT_AROUND; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED"); + ACCEPT WAIT_AROUND; + END TIMED_ENTRY; + + TASK BODY OWNER IS + BEGIN + ACCEPT START DO + WHILE SELF_ABORT'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + END START; + + ABORT OWNER; + + ACCEPT SELF_ABORT; + + END OWNER; + +BEGIN + + TEST("C9A011B", "CHECK THAT ""TASKING_ERROR"" IS RAISED BY A " & + "TIMED ENTRY CALL IF THE CALLED TASK IS " & + "ABORTED BEFORE THE DELAY EXPIRES BUT NOT " & + "WHEN THE CALL IS FIRST EXECUTED"); + + OWNER.START; + DELAY 5.0 * Impdef.One_Second; + + IF TIMED_ENTRY'CALLABLE THEN + TIMED_ENTRY.WAIT_AROUND; + ELSE + FAILED("TASK ABORTED WHEN TASKING ERROR IS RAISED"); + END IF; + + RESULT; + +EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED OUTSIDE OF TASK"); + RESULT; + +END C9A011B; diff --git a/gcc/testsuite/ada/acats/tests/ca/ca1003a.ada b/gcc/testsuite/ada/acats/tests/ca/ca1003a.ada new file mode 100644 index 000000000..b3476b42f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1003a.ada @@ -0,0 +1,73 @@ +-- 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 new file mode 100644 index 000000000..def868edf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1004a.ada @@ -0,0 +1,77 @@ +-- 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 new file mode 100644 index 000000000..9f9e2a283 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1005a.ada @@ -0,0 +1,70 @@ +-- 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 new file mode 100644 index 000000000..7b3527f58 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1006a.ada @@ -0,0 +1,106 @@ +-- 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 new file mode 100644 index 000000000..a1c164642 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1011a0.ada @@ -0,0 +1,35 @@ +-- 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 new file mode 100644 index 000000000..791d78238 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1011a1.ada @@ -0,0 +1,36 @@ +-- 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 new file mode 100644 index 000000000..1125029aa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1011a2.ada @@ -0,0 +1,35 @@ +-- 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 new file mode 100644 index 000000000..a37d04c3e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1011a3.ada @@ -0,0 +1,34 @@ +-- 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 new file mode 100644 index 000000000..68d397240 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1011a4.ada @@ -0,0 +1,35 @@ +-- 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 new file mode 100644 index 000000000..2485717e1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1011a5.ada @@ -0,0 +1,33 @@ +-- 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 new file mode 100644 index 000000000..40c562dd5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1011a6.ada @@ -0,0 +1,71 @@ +-- 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 new file mode 100644 index 000000000..eec972d73 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1012a0.ada @@ -0,0 +1,41 @@ +-- 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 new file mode 100644 index 000000000..0e2522f4b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1012a1.ada @@ -0,0 +1,45 @@ +-- 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 new file mode 100644 index 000000000..63300b3ad --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1012a2.ada @@ -0,0 +1,41 @@ +-- 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 new file mode 100644 index 000000000..310777514 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1012a3.ada @@ -0,0 +1,45 @@ +-- 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 new file mode 100644 index 000000000..f81b97d4b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1012a4.ada @@ -0,0 +1,74 @@ +-- 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 new file mode 100644 index 000000000..b260ca229 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1012b0.ada @@ -0,0 +1,37 @@ +-- 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 new file mode 100644 index 000000000..46d2b9301 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1012b2.ada @@ -0,0 +1,37 @@ +-- 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 new file mode 100644 index 000000000..528ace0d1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1012b4.ada @@ -0,0 +1,63 @@ +-- 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 new file mode 100644 index 000000000..937c25f54 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1013a0.ada @@ -0,0 +1,51 @@ +-- 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 new file mode 100644 index 000000000..ddea320bf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1013a1.ada @@ -0,0 +1,39 @@ +-- 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 new file mode 100644 index 000000000..a6843a8e9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1013a2.ada @@ -0,0 +1,39 @@ +-- 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 new file mode 100644 index 000000000..a4a805b5d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1013a3.ada @@ -0,0 +1,31 @@ +-- 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 new file mode 100644 index 000000000..9828c033b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1013a4.ada @@ -0,0 +1,31 @@ +-- 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 new file mode 100644 index 000000000..bc858539d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1013a5.ada @@ -0,0 +1,30 @@ +-- 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 new file mode 100644 index 000000000..16c266e45 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1013a6.ada @@ -0,0 +1,65 @@ +-- 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 new file mode 100644 index 000000000..cf5e93d96 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1014a0.ada @@ -0,0 +1,85 @@ +-- 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 new file mode 100644 index 000000000..d66b677bb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1014a1.ada @@ -0,0 +1,34 @@ +-- 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 new file mode 100644 index 000000000..9c23ef1f9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1014a2.ada @@ -0,0 +1,39 @@ +-- 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 new file mode 100644 index 000000000..cd76acc6f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1014a3.ada @@ -0,0 +1,34 @@ +-- 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 new file mode 100644 index 000000000..93ecc023f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1020e0.ada @@ -0,0 +1,53 @@ +-- 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 new file mode 100644 index 000000000..e5df714ea --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1020e1.ada @@ -0,0 +1,59 @@ +-- 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 new file mode 100644 index 000000000..7497804fe --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1020e2.ada @@ -0,0 +1,51 @@ +-- 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 new file mode 100644 index 000000000..e8ad70f17 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1020e3.ada @@ -0,0 +1,71 @@ +-- 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 new file mode 100644 index 000000000..c3788cc04 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1022a0.ada @@ -0,0 +1,43 @@ +-- 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 new file mode 100644 index 000000000..89ea74851 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1022a1.ada @@ -0,0 +1,33 @@ +-- 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 new file mode 100644 index 000000000..c7e874b29 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1022a2.ada @@ -0,0 +1,33 @@ +-- 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 new file mode 100644 index 000000000..6c5e9deb7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1022a3.ada @@ -0,0 +1,53 @@ +-- 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 new file mode 100644 index 000000000..17837a659 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1022a4.ada @@ -0,0 +1,36 @@ +-- 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 new file mode 100644 index 000000000..005748ee3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1022a5.ada @@ -0,0 +1,34 @@ +-- 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 new file mode 100644 index 000000000..b011c9bc5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1022a6.ada @@ -0,0 +1,66 @@ +-- 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 new file mode 100644 index 000000000..c9d1e486c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11001.a @@ -0,0 +1,276 @@ +-- 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 new file mode 100644 index 000000000..189e1944c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11002.a @@ -0,0 +1,238 @@ +-- 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 new file mode 100644 index 000000000..ff894250e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11003.a @@ -0,0 +1,290 @@ +-- 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 new file mode 100644 index 000000000..72cc6682e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca110040.a @@ -0,0 +1,90 @@ +-- 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 new file mode 100644 index 000000000..954df7f4d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca110041.a @@ -0,0 +1,118 @@ +-- 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 new file mode 100644 index 000000000..800ed8aae --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca110042.am @@ -0,0 +1,130 @@ +-- 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 new file mode 100644 index 000000000..88455762c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca110050.a @@ -0,0 +1,99 @@ +-- 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 new file mode 100644 index 000000000..91af06823 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca110051.am @@ -0,0 +1,224 @@ +-- 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 new file mode 100644 index 000000000..5cd21fe1f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11006.a @@ -0,0 +1,211 @@ +-- 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 new file mode 100644 index 000000000..c4a6789ab --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11007.a @@ -0,0 +1,228 @@ +-- 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 new file mode 100644 index 000000000..1161fbe0c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11008.a @@ -0,0 +1,216 @@ +-- 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 new file mode 100644 index 000000000..84d7dc2b3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11009.a @@ -0,0 +1,246 @@ +-- 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 new file mode 100644 index 000000000..b13efd798 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11010.a @@ -0,0 +1,254 @@ +-- 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 new file mode 100644 index 000000000..a75261dd8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11011.a @@ -0,0 +1,271 @@ +-- 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 new file mode 100644 index 000000000..071b8f813 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11012.a @@ -0,0 +1,259 @@ +-- 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 new file mode 100644 index 000000000..c7f442788 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11013.a @@ -0,0 +1,201 @@ +-- 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 new file mode 100644 index 000000000..7847a5067 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11014.a @@ -0,0 +1,302 @@ +-- 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 new file mode 100644 index 000000000..79b99ede8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11015.a @@ -0,0 +1,312 @@ +-- 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 new file mode 100644 index 000000000..d6d4089a9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11016.a @@ -0,0 +1,321 @@ +-- 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 new file mode 100644 index 000000000..cbcce701d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11017.a @@ -0,0 +1,246 @@ +-- 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 new file mode 100644 index 000000000..a01ebfc32 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11018.a @@ -0,0 +1,366 @@ +-- 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 new file mode 100644 index 000000000..92b3ba535 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11019.a @@ -0,0 +1,306 @@ +-- 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 new file mode 100644 index 000000000..4949ce9fe --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11020.a @@ -0,0 +1,238 @@ +-- 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 new file mode 100644 index 000000000..f4da2f913 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11021.a @@ -0,0 +1,245 @@ +-- 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 new file mode 100644 index 000000000..60cbc08ce --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11022.a @@ -0,0 +1,242 @@ +-- 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 new file mode 100644 index 000000000..23f766fb5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1102a0.ada @@ -0,0 +1,31 @@ +-- 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 new file mode 100644 index 000000000..e201a5148 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1102a1.ada @@ -0,0 +1,36 @@ +-- 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 new file mode 100644 index 000000000..b4cffd124 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1102a2.ada @@ -0,0 +1,58 @@ +-- 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 new file mode 100644 index 000000000..b3da9d102 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1106a.ada @@ -0,0 +1,112 @@ +-- 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 new file mode 100644 index 000000000..7059d26c8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1108a.ada @@ -0,0 +1,136 @@ +-- 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 new file mode 100644 index 000000000..287772836 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca1108b.ada @@ -0,0 +1,168 @@ +-- 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 new file mode 100644 index 000000000..a84c6b84f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11a01.a @@ -0,0 +1,228 @@ +-- 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 new file mode 100644 index 000000000..e7c161423 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11a02.a @@ -0,0 +1,156 @@ +-- 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 new file mode 100644 index 000000000..8d6de02f1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11b01.a @@ -0,0 +1,208 @@ +-- 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 new file mode 100644 index 000000000..0743f7333 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11b02.a @@ -0,0 +1,169 @@ +-- 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 new file mode 100644 index 000000000..195ec2d40 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11c01.a @@ -0,0 +1,170 @@ +-- 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 new file mode 100644 index 000000000..7d8749328 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11c02.a @@ -0,0 +1,158 @@ +-- 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 new file mode 100644 index 000000000..b75a66034 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11c03.a @@ -0,0 +1,186 @@ +-- 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 new file mode 100644 index 000000000..7ea0e2267 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11d010.a @@ -0,0 +1,119 @@ +-- 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 new file mode 100644 index 000000000..014f74be7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11d011.a @@ -0,0 +1,79 @@ +-- 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 new file mode 100644 index 000000000..1bb3bd7ac --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11d012.a @@ -0,0 +1,73 @@ +-- 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 new file mode 100644 index 000000000..6cbd3bbcc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11d013.am @@ -0,0 +1,256 @@ +-- 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 new file mode 100644 index 000000000..7b4f48869 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11d02.a @@ -0,0 +1,393 @@ +-- 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 new file mode 100644 index 000000000..901b8d217 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11d03.a @@ -0,0 +1,174 @@ +-- 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 new file mode 100644 index 000000000..094bd7a88 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca13001.a @@ -0,0 +1,370 @@ +-- 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 new file mode 100644 index 000000000..e985174af --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca13002.a @@ -0,0 +1,259 @@ +-- 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 new file mode 100644 index 000000000..607639efe --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca13003.a @@ -0,0 +1,256 @@ +-- 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 new file mode 100644 index 000000000..3963bc61f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca13a01.a @@ -0,0 +1,320 @@ +-- 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 new file mode 100644 index 000000000..82d1b6ea5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca13a02.a @@ -0,0 +1,301 @@ +-- 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 new file mode 100644 index 000000000..95b72b1ab --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca140230.a @@ -0,0 +1,62 @@ +-- 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 new file mode 100644 index 000000000..32504b590 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca140231.a @@ -0,0 +1,59 @@ +-- 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 new file mode 100644 index 000000000..d9ffba28f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca140232.am @@ -0,0 +1,139 @@ +-- 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 new file mode 100644 index 000000000..a5334379d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca140233.a @@ -0,0 +1,68 @@ +-- 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 new file mode 100644 index 000000000..1ffe3cbbf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca140280.a @@ -0,0 +1,77 @@ +-- 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 new file mode 100644 index 000000000..57360c9eb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca140281.a @@ -0,0 +1,67 @@ +-- 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 new file mode 100644 index 000000000..437f01889 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca140282.a @@ -0,0 +1,64 @@ +-- 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 new file mode 100644 index 000000000..9a74b8d70 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca140283.am @@ -0,0 +1,91 @@ +-- 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 new file mode 100644 index 000000000..08fe1516d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca15003.a @@ -0,0 +1,161 @@ +-- 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 new file mode 100644 index 000000000..c9508f4cc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca200020.a @@ -0,0 +1,70 @@ +-- 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 new file mode 100644 index 000000000..0c5de3825 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca200021.a @@ -0,0 +1,66 @@ +-- 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 new file mode 100644 index 000000000..1e9b773e0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca200022.am @@ -0,0 +1,64 @@ +-- 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 new file mode 100644 index 000000000..f40744fbd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2001h0.ada @@ -0,0 +1,40 @@ +-- 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 new file mode 100644 index 000000000..db0797d72 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2001h1.ada @@ -0,0 +1,39 @@ +-- 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 new file mode 100644 index 000000000..c6f672b15 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2001h2.ada @@ -0,0 +1,38 @@ +-- 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 new file mode 100644 index 000000000..9da25eea1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2001h3.ada @@ -0,0 +1,66 @@ +-- 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 new file mode 100644 index 000000000..f48f58bd3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2002a0.ada @@ -0,0 +1,139 @@ +-- 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 new file mode 100644 index 000000000..064ec4d0f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2002a1.ada @@ -0,0 +1,53 @@ +-- 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 new file mode 100644 index 000000000..6a1bc584c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2002a2.ada @@ -0,0 +1,53 @@ +-- 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 new file mode 100644 index 000000000..d6e47b46c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2003a0.ada @@ -0,0 +1,55 @@ +-- 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 new file mode 100644 index 000000000..ec09f13c8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2003a1.ada @@ -0,0 +1,35 @@ +-- 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 new file mode 100644 index 000000000..4eae5e241 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2004a0.ada @@ -0,0 +1,65 @@ +-- 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 new file mode 100644 index 000000000..2dcfd459f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2004a1.ada @@ -0,0 +1,34 @@ +-- 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 new file mode 100644 index 000000000..739152fcd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2004a2.ada @@ -0,0 +1,43 @@ +-- 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 new file mode 100644 index 000000000..528f4e2d5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2004a3.ada @@ -0,0 +1,39 @@ +-- 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 new file mode 100644 index 000000000..a71ca33f6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2004a4.ada @@ -0,0 +1,36 @@ +-- 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 new file mode 100644 index 000000000..fb9e0b4ce --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2007a0.ada @@ -0,0 +1,77 @@ +-- 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 new file mode 100644 index 000000000..bef16f5ce --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2007a1.ada @@ -0,0 +1,36 @@ +-- 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 new file mode 100644 index 000000000..9429ea4dd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2007a2.ada @@ -0,0 +1,36 @@ +-- 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 new file mode 100644 index 000000000..1d4886c6f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2007a3.ada @@ -0,0 +1,36 @@ +-- 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 new file mode 100644 index 000000000..542591c52 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2008a0.ada @@ -0,0 +1,81 @@ +-- 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 new file mode 100644 index 000000000..7154a8d88 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2008a1.ada @@ -0,0 +1,35 @@ +-- 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 new file mode 100644 index 000000000..d8fd4399c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2008a2.ada @@ -0,0 +1,35 @@ +-- 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 new file mode 100644 index 000000000..4953045dc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2009a.ada @@ -0,0 +1,77 @@ +-- 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 new file mode 100644 index 000000000..aedd31ba8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2009c0.ada @@ -0,0 +1,83 @@ +-- 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 new file mode 100644 index 000000000..6bf9a4bb6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2009c1.ada @@ -0,0 +1,43 @@ +-- 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 new file mode 100644 index 000000000..65b5d8113 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2009d.ada @@ -0,0 +1,95 @@ +-- 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 new file mode 100644 index 000000000..8bc23c11d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2009f0.ada @@ -0,0 +1,134 @@ +-- 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 new file mode 100644 index 000000000..e3e13cedb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2009f1.ada @@ -0,0 +1,43 @@ +-- 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 new file mode 100644 index 000000000..201a43835 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2009f2.ada @@ -0,0 +1,45 @@ +-- 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 new file mode 100644 index 000000000..c1c3be5a0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca2011b.ada @@ -0,0 +1,118 @@ +-- 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 new file mode 100644 index 000000000..1056b65bf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca21001.a @@ -0,0 +1,152 @@ +-- 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 new file mode 100644 index 000000000..fdbc141a3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca3011a0.ada @@ -0,0 +1,74 @@ +-- 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 new file mode 100644 index 000000000..5c53cf35b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca3011a1.ada @@ -0,0 +1,42 @@ +-- 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 new file mode 100644 index 000000000..87aacfa18 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca3011a2.ada @@ -0,0 +1,42 @@ +-- 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 new file mode 100644 index 000000000..eb582b84b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca3011a3.ada @@ -0,0 +1,43 @@ +-- 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 new file mode 100644 index 000000000..70cad219c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca3011a4.ada @@ -0,0 +1,61 @@ +-- 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 new file mode 100644 index 000000000..302314b4e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003a0.ada @@ -0,0 +1,50 @@ +-- 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 new file mode 100644 index 000000000..7f9f3b259 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003a1.ada @@ -0,0 +1,34 @@ +-- 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 new file mode 100644 index 000000000..9d36ab2a0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003a2.ada @@ -0,0 +1,34 @@ +-- 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 new file mode 100644 index 000000000..96145677c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003a3.ada @@ -0,0 +1,34 @@ +-- 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 new file mode 100644 index 000000000..908b39e42 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003a4.ada @@ -0,0 +1,34 @@ +-- 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 new file mode 100644 index 000000000..a8e07fea9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003a5.ada @@ -0,0 +1,34 @@ +-- 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 new file mode 100644 index 000000000..df12c4e88 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003a6.ada @@ -0,0 +1,71 @@ +-- 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 new file mode 100644 index 000000000..9851ca328 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003b0.ada @@ -0,0 +1,51 @@ +-- 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 new file mode 100644 index 000000000..ba70ecc38 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003b1.ada @@ -0,0 +1,46 @@ +-- 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 new file mode 100644 index 000000000..a524a0088 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003b2.ada @@ -0,0 +1,45 @@ +-- 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 new file mode 100644 index 000000000..8706a0637 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003b3.ada @@ -0,0 +1,35 @@ +-- 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 new file mode 100644 index 000000000..d3c2f7e2d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003b4.ada @@ -0,0 +1,40 @@ +-- 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 new file mode 100644 index 000000000..4beb61ed1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5003b5.ada @@ -0,0 +1,65 @@ +-- 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 new file mode 100644 index 000000000..34a735ef0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5004a.ada @@ -0,0 +1,105 @@ +-- 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 new file mode 100644 index 000000000..bb7947027 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5004b0.ada @@ -0,0 +1,64 @@ +-- 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 new file mode 100644 index 000000000..068ae88a0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5004b1.ada @@ -0,0 +1,56 @@ +-- 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 new file mode 100644 index 000000000..bae6280dc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5004b2.ada @@ -0,0 +1,153 @@ +-- 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 new file mode 100644 index 000000000..cc4d3c9dd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca5006a.ada @@ -0,0 +1,145 @@ +-- 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 new file mode 100644 index 000000000..f3099d4a2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb10002.a @@ -0,0 +1,128 @@ +-- 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 new file mode 100644 index 000000000..5cd5391e5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb1001a.ada @@ -0,0 +1,102 @@ +-- 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 new file mode 100644 index 000000000..d137d0e32 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb1004a.ada @@ -0,0 +1,85 @@ +-- 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 new file mode 100644 index 000000000..94e5383b3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb1005a.ada @@ -0,0 +1,164 @@ +-- 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 new file mode 100644 index 000000000..ac0a7793a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb1010a.ada @@ -0,0 +1,179 @@ +-- 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 new file mode 100644 index 000000000..bcd95041a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb1010c.ada @@ -0,0 +1,70 @@ +-- 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 new file mode 100644 index 000000000..e58046c85 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb1010d.ada @@ -0,0 +1,92 @@ +-- 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 new file mode 100644 index 000000000..ccfad52e4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb20001.a @@ -0,0 +1,228 @@ +-- 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 new file mode 100644 index 000000000..daaf9ffe5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb20003.a @@ -0,0 +1,286 @@ +-- 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 new file mode 100644 index 000000000..42c0d7672 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb20004.a @@ -0,0 +1,203 @@ +-- 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 new file mode 100644 index 000000000..898d2a2c6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb20005.a @@ -0,0 +1,210 @@ +-- 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 new file mode 100644 index 000000000..f2b3c70a9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb20006.a @@ -0,0 +1,217 @@ +-- 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 new file mode 100644 index 000000000..6d052517e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb20007.a @@ -0,0 +1,196 @@ +-- 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 new file mode 100644 index 000000000..e16aeb5d0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb2004a.ada @@ -0,0 +1,245 @@ +-- 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 new file mode 100644 index 000000000..64ac5a786 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb2005a.ada @@ -0,0 +1,77 @@ +-- 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 new file mode 100644 index 000000000..b4da0e2cc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb2006a.ada @@ -0,0 +1,70 @@ +-- 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 new file mode 100644 index 000000000..01e12d834 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb2007a.ada @@ -0,0 +1,104 @@ +-- 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 new file mode 100644 index 000000000..4c8537086 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb20a02.a @@ -0,0 +1,155 @@ +-- 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 new file mode 100644 index 000000000..3acdd2eda --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb3003a.ada @@ -0,0 +1,164 @@ +-- 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 new file mode 100644 index 000000000..460670f03 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb3003b.ada @@ -0,0 +1,135 @@ +-- 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 new file mode 100644 index 000000000..b089bc255 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb3004a.ada @@ -0,0 +1,145 @@ +-- 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 new file mode 100644 index 000000000..681ec18ff --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb40005.a @@ -0,0 +1,339 @@ +-- 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 new file mode 100644 index 000000000..010add15c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb4001a.ada @@ -0,0 +1,151 @@ +-- 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 new file mode 100644 index 000000000..e37525769 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb4002a.ada @@ -0,0 +1,127 @@ +-- 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 new file mode 100644 index 000000000..7f1aaf5e2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb4003a.ada @@ -0,0 +1,119 @@ +-- 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 new file mode 100644 index 000000000..228d0a4ee --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb4004a.ada @@ -0,0 +1,77 @@ +-- 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 new file mode 100644 index 000000000..5b68ac39b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb4005a.ada @@ -0,0 +1,66 @@ +-- 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 new file mode 100644 index 000000000..b0ddfc57a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb4006a.ada @@ -0,0 +1,97 @@ +-- 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 new file mode 100644 index 000000000..789d1b330 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb4007a.ada @@ -0,0 +1,115 @@ +-- 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 new file mode 100644 index 000000000..741a7a8f0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb4008a.ada @@ -0,0 +1,137 @@ +-- 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 new file mode 100644 index 000000000..98f009e4b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb4009a.ada @@ -0,0 +1,114 @@ +-- 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 new file mode 100644 index 000000000..655b80035 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb4013a.ada @@ -0,0 +1,80 @@ +-- 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 new file mode 100644 index 000000000..1c569119a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb40a01.a @@ -0,0 +1,135 @@ +-- 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 new file mode 100644 index 000000000..09830b87f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb40a020.a @@ -0,0 +1,95 @@ +-- 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 new file mode 100644 index 000000000..027b7da9d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb40a021.am @@ -0,0 +1,103 @@ +-- 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 new file mode 100644 index 000000000..8b053e2f0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb40a030.a @@ -0,0 +1,105 @@ +-- 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 new file mode 100644 index 000000000..6f2f2aa99 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb40a031.am @@ -0,0 +1,102 @@ +-- 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 new file mode 100644 index 000000000..45209b9be --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb40a04.a @@ -0,0 +1,119 @@ +-- 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 new file mode 100644 index 000000000..95ad868fe --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb41001.a @@ -0,0 +1,213 @@ +-- 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 new file mode 100644 index 000000000..1b3898154 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb41002.a @@ -0,0 +1,283 @@ +-- 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 new file mode 100644 index 000000000..aee0b094c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb41003.a @@ -0,0 +1,358 @@ +-- 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 new file mode 100644 index 000000000..5a7b70494 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb41004.a @@ -0,0 +1,299 @@ +-- 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. +-- Notes for future: Replace Exception_Identity +-- subtest with whatever the resolution is. +-- Add a subtest for Exception_Name(Null_Id), which +-- is missing from this test. +--! + +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 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. +-- -- Note: (RLB, 2000/12/08) This behavior may be modified by AI-00241. +-- -- As such, this test case has been removed pending a resolution. +-- begin +-- declare +-- Id : Ada.Exceptions.Exception_Id := +-- Ada.Exceptions.Exception_Identity(A_Null_Exception_Occurrence); +-- begin +-- Report.Failed +-- ("Constraint_Error not raised by Function Exception_Identity " & +-- "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_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 new file mode 100644 index 000000000..5cf563fdc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb5001a.ada @@ -0,0 +1,87 @@ +-- 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 new file mode 100644 index 000000000..35dff52f7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb5001b.ada @@ -0,0 +1,106 @@ +-- 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 new file mode 100644 index 000000000..f4484bcc4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cb/cb5002a.ada @@ -0,0 +1,168 @@ +-- 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 new file mode 100644 index 000000000..f5a148115 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1004a.ada @@ -0,0 +1,108 @@ +-- 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 new file mode 100644 index 000000000..484227fab --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1005b.ada @@ -0,0 +1,151 @@ +-- 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 new file mode 100644 index 000000000..c04a3253c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1010a.ada @@ -0,0 +1,66 @@ +-- 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 new file mode 100644 index 000000000..74ef437b9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1010b.ada @@ -0,0 +1,67 @@ +-- 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 new file mode 100644 index 000000000..2ea39a928 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1018a.ada @@ -0,0 +1,83 @@ +-- 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 new file mode 100644 index 000000000..a97e7a097 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1104c.ada @@ -0,0 +1,151 @@ +-- 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 new file mode 100644 index 000000000..94a177615 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1107b.ada @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..709307d13 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1111a.ada @@ -0,0 +1,322 @@ +-- 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 new file mode 100644 index 000000000..17e3d7f0f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1204a.ada @@ -0,0 +1,115 @@ +-- 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 new file mode 100644 index 000000000..b8eeae495 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1207b.ada @@ -0,0 +1,138 @@ +-- 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 new file mode 100644 index 000000000..cabd5911a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1220a.ada @@ -0,0 +1,174 @@ +-- 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 new file mode 100644 index 000000000..0749e86f3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1221a.ada @@ -0,0 +1,141 @@ +-- 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 new file mode 100644 index 000000000..2e4d816d4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1221b.ada @@ -0,0 +1,159 @@ +-- 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 new file mode 100644 index 000000000..21738858e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1221c.ada @@ -0,0 +1,195 @@ +-- 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 new file mode 100644 index 000000000..931d01627 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1221d.ada @@ -0,0 +1,173 @@ +-- 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 new file mode 100644 index 000000000..f6f65896c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1222a.ada @@ -0,0 +1,290 @@ +-- 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 new file mode 100644 index 000000000..1f9b0052f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1223a.ada @@ -0,0 +1,297 @@ +-- 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 new file mode 100644 index 000000000..c419fb7e4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1224a.ada @@ -0,0 +1,558 @@ +-- 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 new file mode 100644 index 000000000..dfad3b0ed --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1225a.tst @@ -0,0 +1,350 @@ +-- 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 new file mode 100644 index 000000000..c127dc15b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1226b.ada @@ -0,0 +1,176 @@ +-- 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 new file mode 100644 index 000000000..39b453287 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1227a.ada @@ -0,0 +1,289 @@ +-- 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 new file mode 100644 index 000000000..92c94d033 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1301a.ada @@ -0,0 +1,164 @@ +-- 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 new file mode 100644 index 000000000..c61a310d5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1302a.ada @@ -0,0 +1,174 @@ +-- 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 new file mode 100644 index 000000000..2556c9d38 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1304a.ada @@ -0,0 +1,122 @@ +-- 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 new file mode 100644 index 000000000..10086e829 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1304b.ada @@ -0,0 +1,166 @@ +-- 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 new file mode 100644 index 000000000..932b5ffcf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1307a.ada @@ -0,0 +1,54 @@ +-- 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 new file mode 100644 index 000000000..c5eb15a42 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1307b.ada @@ -0,0 +1,88 @@ +-- 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 new file mode 100644 index 000000000..69a558f72 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1308a.ada @@ -0,0 +1,266 @@ +-- 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 new file mode 100644 index 000000000..28ea40941 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1310a.ada @@ -0,0 +1,88 @@ +-- 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 new file mode 100644 index 000000000..ce38abe55 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1311a.ada @@ -0,0 +1,480 @@ +-- 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 new file mode 100644 index 000000000..eb30726b8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc1311b.ada @@ -0,0 +1,332 @@ +-- 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 new file mode 100644 index 000000000..95b9e91ef --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc2002a.ada @@ -0,0 +1,77 @@ +-- 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 new file mode 100644 index 000000000..69010e421 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc30001.a @@ -0,0 +1,219 @@ +-- 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 new file mode 100644 index 000000000..5132f8cae --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc30002.a @@ -0,0 +1,349 @@ +-- 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 new file mode 100644 index 000000000..5e65adf63 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3004a.ada @@ -0,0 +1,87 @@ +-- 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 new file mode 100644 index 000000000..e9d6daa8d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3007a.ada @@ -0,0 +1,118 @@ +-- 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 new file mode 100644 index 000000000..22bd4c0a3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3007b.ada @@ -0,0 +1,397 @@ +-- 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 new file mode 100644 index 000000000..8ecba226e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3011a.ada @@ -0,0 +1,131 @@ +-- 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 new file mode 100644 index 000000000..26dfde26a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3011d.ada @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..da465017d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3012a.ada @@ -0,0 +1,247 @@ +-- 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 new file mode 100644 index 000000000..ca3543c44 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3015a.ada @@ -0,0 +1,104 @@ +-- 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 new file mode 100644 index 000000000..2fbc09062 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3016b.ada @@ -0,0 +1,396 @@ +-- 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 new file mode 100644 index 000000000..637617027 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3016c.ada @@ -0,0 +1,192 @@ +-- 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 new file mode 100644 index 000000000..9a1f099c1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3016f.ada @@ -0,0 +1,187 @@ +-- 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. +--* +-- OFFICE, 3E 114, THE PENTAGON, WASHINGTON DC 20301-3081. + +-- 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 new file mode 100644 index 000000000..933ec84b3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3016i.ada @@ -0,0 +1,78 @@ +-- 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 new file mode 100644 index 000000000..0f8fcfd6f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3017b.ada @@ -0,0 +1,470 @@ +-- 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 new file mode 100644 index 000000000..d4649716f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3017c.ada @@ -0,0 +1,336 @@ +-- 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 new file mode 100644 index 000000000..3f5e84e60 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3019a.ada @@ -0,0 +1,173 @@ +-- 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 new file mode 100644 index 000000000..b7a7a9d4e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3019b0.ada @@ -0,0 +1,191 @@ +-- 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 new file mode 100644 index 000000000..15dcb1370 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3019b1.ada @@ -0,0 +1,174 @@ +-- 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 new file mode 100644 index 000000000..52bf79ddc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3019b2.ada @@ -0,0 +1,300 @@ +-- 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 new file mode 100644 index 000000000..d34ff79f0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3019c0.ada @@ -0,0 +1,191 @@ +-- 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 new file mode 100644 index 000000000..527c27f5a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3019c1.ada @@ -0,0 +1,331 @@ +-- 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 new file mode 100644 index 000000000..8fab9e623 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3019c2.ada @@ -0,0 +1,457 @@ +-- 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 new file mode 100644 index 000000000..cd238c17a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3106b.ada @@ -0,0 +1,207 @@ +-- 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 new file mode 100644 index 000000000..dc709c322 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3120a.ada @@ -0,0 +1,180 @@ +-- 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 new file mode 100644 index 000000000..d25f4443f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3120b.ada @@ -0,0 +1,146 @@ +-- 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 new file mode 100644 index 000000000..a0a8e4aaf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3121a.ada @@ -0,0 +1,183 @@ +-- 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 new file mode 100644 index 000000000..917f5fd45 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3123a.ada @@ -0,0 +1,198 @@ +-- 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 new file mode 100644 index 000000000..4adff6d2d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3125a.ada @@ -0,0 +1,111 @@ +-- 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 new file mode 100644 index 000000000..84d6d1198 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3125b.ada @@ -0,0 +1,148 @@ +-- 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 new file mode 100644 index 000000000..42904bdfb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3125c.ada @@ -0,0 +1,148 @@ +-- 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 new file mode 100644 index 000000000..5977eb91a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3125d.ada @@ -0,0 +1,148 @@ +-- 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 new file mode 100644 index 000000000..ba234648b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3126a.ada @@ -0,0 +1,188 @@ +-- 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 new file mode 100644 index 000000000..9e1ccdb68 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3127a.ada @@ -0,0 +1,143 @@ +-- 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 new file mode 100644 index 000000000..9afdd77d2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3128a.ada @@ -0,0 +1,358 @@ +-- 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 new file mode 100644 index 000000000..b0228ea92 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3203a.ada @@ -0,0 +1,89 @@ +-- 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 new file mode 100644 index 000000000..8b6fa03ae --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3207b.ada @@ -0,0 +1,119 @@ +-- 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 new file mode 100644 index 000000000..d80ec17ea --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3220a.ada @@ -0,0 +1,163 @@ +-- 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 new file mode 100644 index 000000000..e7c7287da --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3221a.ada @@ -0,0 +1,107 @@ +-- 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 new file mode 100644 index 000000000..57cb19881 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3222a.ada @@ -0,0 +1,116 @@ +-- 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 new file mode 100644 index 000000000..469a4963e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3223a.ada @@ -0,0 +1,114 @@ +-- 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 new file mode 100644 index 000000000..5da67ea4c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3224a.ada @@ -0,0 +1,313 @@ +-- 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 new file mode 100644 index 000000000..478664f43 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3225a.ada @@ -0,0 +1,183 @@ +-- 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 new file mode 100644 index 000000000..7f40896a9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3230a.ada @@ -0,0 +1,133 @@ +-- 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 new file mode 100644 index 000000000..a36bccfc8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3231a.ada @@ -0,0 +1,177 @@ +-- 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 new file mode 100644 index 000000000..9b4b5445d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3232a.ada @@ -0,0 +1,179 @@ +-- 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 new file mode 100644 index 000000000..c344cfc97 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3233a.ada @@ -0,0 +1,175 @@ +-- 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 new file mode 100644 index 000000000..487b26c89 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3234a.ada @@ -0,0 +1,147 @@ +-- 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 new file mode 100644 index 000000000..f32c3e128 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3235a.ada @@ -0,0 +1,129 @@ +-- 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 new file mode 100644 index 000000000..d02dec25e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3236a.ada @@ -0,0 +1,117 @@ +-- 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 new file mode 100644 index 000000000..1983b9429 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3240a.ada @@ -0,0 +1,122 @@ +-- 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 new file mode 100644 index 000000000..66d0f38c4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3305a.ada @@ -0,0 +1,103 @@ +-- 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 new file mode 100644 index 000000000..7273c689e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3305b.ada @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..6cb53a87b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3305c.ada @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..1faa64f62 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3305d.ada @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..198f47ecd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3601a.ada @@ -0,0 +1,251 @@ +-- 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 new file mode 100644 index 000000000..a0119776d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3601c.ada @@ -0,0 +1,149 @@ +-- 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 new file mode 100644 index 000000000..005995e99 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3602a.ada @@ -0,0 +1,146 @@ +-- 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 new file mode 100644 index 000000000..45e65b25f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3603a.ada @@ -0,0 +1,97 @@ +-- 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 new file mode 100644 index 000000000..b9fb50b1b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3605a.ada @@ -0,0 +1,381 @@ +-- 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 new file mode 100644 index 000000000..4d63b7143 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3606a.ada @@ -0,0 +1,134 @@ +-- 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 new file mode 100644 index 000000000..79dc8a7ba --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3606b.ada @@ -0,0 +1,134 @@ +-- 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 new file mode 100644 index 000000000..701c739cf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc3607b.ada @@ -0,0 +1,79 @@ +-- 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 new file mode 100644 index 000000000..bf42470e6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc40001.a @@ -0,0 +1,403 @@ +-- 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 new file mode 100644 index 000000000..32a1afeb3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc50001.a @@ -0,0 +1,257 @@ +-- 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 new file mode 100644 index 000000000..4d5dfdfd5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc50a01.a @@ -0,0 +1,313 @@ +-- 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 new file mode 100644 index 000000000..6c2bf5fb0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc50a02.a @@ -0,0 +1,227 @@ +-- 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 new file mode 100644 index 000000000..6aa76a6f8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc51001.a @@ -0,0 +1,186 @@ +-- 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 new file mode 100644 index 000000000..1083d18a8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc51002.a @@ -0,0 +1,198 @@ +-- 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 new file mode 100644 index 000000000..68ea32ebd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc51003.a @@ -0,0 +1,187 @@ +-- 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 new file mode 100644 index 000000000..09b1b57fa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc51004.a @@ -0,0 +1,181 @@ +-- 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 new file mode 100644 index 000000000..b4dc4cdb4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc51006.a @@ -0,0 +1,224 @@ +-- 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 new file mode 100644 index 000000000..d8f78779d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc51007.a @@ -0,0 +1,305 @@ +-- 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 new file mode 100644 index 000000000..b95ae6cf0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc51008.a @@ -0,0 +1,124 @@ +-- 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 new file mode 100644 index 000000000..60c32be47 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc51a01.a @@ -0,0 +1,193 @@ +-- 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 new file mode 100644 index 000000000..0cbeeb46f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc51b03.a @@ -0,0 +1,258 @@ +-- 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 new file mode 100644 index 000000000..63c68c0d4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc51d01.a @@ -0,0 +1,262 @@ +-- 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 new file mode 100644 index 000000000..520556391 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc51d02.a @@ -0,0 +1,244 @@ +-- 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 new file mode 100644 index 000000000..eb297d0ec --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc54001.a @@ -0,0 +1,184 @@ +-- 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 new file mode 100644 index 000000000..623f25d6c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc54002.a @@ -0,0 +1,223 @@ +-- 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 new file mode 100644 index 000000000..d8aaeaf9c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc54003.a @@ -0,0 +1,234 @@ +-- 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 new file mode 100644 index 000000000..0023b3a74 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc54004.a @@ -0,0 +1,295 @@ +-- 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 new file mode 100644 index 000000000..65681b072 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc70001.a @@ -0,0 +1,309 @@ +-- 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 new file mode 100644 index 000000000..3e4d9c40b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc70002.a @@ -0,0 +1,241 @@ +-- 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 new file mode 100644 index 000000000..d2309fc36 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc70003.a @@ -0,0 +1,212 @@ +-- 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 new file mode 100644 index 000000000..ac92f437a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc70a01.a @@ -0,0 +1,208 @@ +-- 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 new file mode 100644 index 000000000..3601ce443 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc70a02.a @@ -0,0 +1,193 @@ +-- 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 new file mode 100644 index 000000000..6c514e17b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc70b01.a @@ -0,0 +1,170 @@ +-- 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 new file mode 100644 index 000000000..d27eea843 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc70b02.a @@ -0,0 +1,222 @@ +-- 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 new file mode 100644 index 000000000..f22ad01e7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc70c01.a @@ -0,0 +1,187 @@ +-- 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 new file mode 100644 index 000000000..f479193b5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc70c02.a @@ -0,0 +1,192 @@ +-- 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 new file mode 100644 index 000000000..6b44067c9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd10001.a @@ -0,0 +1,300 @@ +-- 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 new file mode 100644 index 000000000..fc56d4299 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd10002.a @@ -0,0 +1,1198 @@ +-- 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 new file mode 100644 index 000000000..905675a7f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009a.ada @@ -0,0 +1,80 @@ +-- 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 new file mode 100644 index 000000000..2cbc9e77f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009b.ada @@ -0,0 +1,80 @@ +-- 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 new file mode 100644 index 000000000..738235f65 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009d.ada @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..4524358fa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009e.ada @@ -0,0 +1,82 @@ +-- 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 new file mode 100644 index 000000000..8bcde28c5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009f.ada @@ -0,0 +1,83 @@ +-- 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 new file mode 100644 index 000000000..1a1426b5c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009g.ada @@ -0,0 +1,86 @@ +-- 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 new file mode 100644 index 000000000..35cccb522 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009h.ada @@ -0,0 +1,79 @@ +-- 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 new file mode 100644 index 000000000..ba35fed3a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009i.ada @@ -0,0 +1,69 @@ +-- 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 new file mode 100644 index 000000000..dcae459af --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009j.ada @@ -0,0 +1,66 @@ +-- 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 new file mode 100644 index 000000000..02a824abf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009k.tst @@ -0,0 +1,94 @@ +-- 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 new file mode 100644 index 000000000..61bca0d49 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009l.ada @@ -0,0 +1,69 @@ +-- 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 new file mode 100644 index 000000000..7e1932a43 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009m.ada @@ -0,0 +1,81 @@ +-- 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 new file mode 100644 index 000000000..9ebcaa106 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009n.ada @@ -0,0 +1,147 @@ +-- 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 new file mode 100644 index 000000000..4317a0d05 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009o.ada @@ -0,0 +1,75 @@ +-- 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 new file mode 100644 index 000000000..3dcc29a6e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009p.ada @@ -0,0 +1,66 @@ +-- 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 new file mode 100644 index 000000000..e6c88d837 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009q.ada @@ -0,0 +1,75 @@ +-- 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 new file mode 100644 index 000000000..fe2bd21f7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009r.ada @@ -0,0 +1,64 @@ +-- 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 new file mode 100644 index 000000000..ef67765a6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009s.ada @@ -0,0 +1,72 @@ +-- 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 new file mode 100644 index 000000000..1ed4b53e6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009t.tst @@ -0,0 +1,77 @@ +-- 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 new file mode 100644 index 000000000..de803d480 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009u.tst @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..945e236c2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009v.ada @@ -0,0 +1,76 @@ +-- 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 new file mode 100644 index 000000000..ef06e43f0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009w.ada @@ -0,0 +1,71 @@ +-- 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 new file mode 100644 index 000000000..045be9455 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009x.ada @@ -0,0 +1,105 @@ +-- 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 new file mode 100644 index 000000000..1300c17f8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009y.ada @@ -0,0 +1,115 @@ +-- 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 new file mode 100644 index 000000000..61e6b1314 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1009z.ada @@ -0,0 +1,115 @@ +-- 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 new file mode 100644 index 000000000..1b4bf239c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1c03a.ada @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..5536ead82 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1c03b.ada @@ -0,0 +1,78 @@ +-- 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 new file mode 100644 index 000000000..9e37bb4b0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1c03c.ada @@ -0,0 +1,71 @@ +-- 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 new file mode 100644 index 000000000..8b706c553 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1c03e.tst @@ -0,0 +1,82 @@ +-- 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 new file mode 100644 index 000000000..3686710c6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1c03f.ada @@ -0,0 +1,76 @@ +-- 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 new file mode 100644 index 000000000..898b68a1b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1c03g.ada @@ -0,0 +1,65 @@ +-- 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 new file mode 100644 index 000000000..ad84e9196 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1c03h.ada @@ -0,0 +1,122 @@ +-- 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 new file mode 100644 index 000000000..25ad2e082 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1c03i.ada @@ -0,0 +1,115 @@ +-- 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 new file mode 100644 index 000000000..2c04b1e7b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1c04a.ada @@ -0,0 +1,147 @@ +-- 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 new file mode 100644 index 000000000..9e95b546d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1c04d.ada @@ -0,0 +1,80 @@ +-- 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 new file mode 100644 index 000000000..21c7a7eef --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1c04e.ada @@ -0,0 +1,124 @@ +-- 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 new file mode 100644 index 000000000..fff91a357 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd1c06a.tst @@ -0,0 +1,100 @@ +-- 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 new file mode 100644 index 000000000..21f973873 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd20001.a @@ -0,0 +1,275 @@ +-- 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 new file mode 100644 index 000000000..6f42d393c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a21a.ada @@ -0,0 +1,215 @@ +-- 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 new file mode 100644 index 000000000..0fc6fb127 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a21c.ada @@ -0,0 +1,116 @@ +-- 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 new file mode 100644 index 000000000..c241ea39d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a21e.ada @@ -0,0 +1,153 @@ +-- 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 new file mode 100644 index 000000000..37564d807 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a22a.ada @@ -0,0 +1,213 @@ +-- 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 new file mode 100644 index 000000000..2ed878c5b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a22e.ada @@ -0,0 +1,216 @@ +-- 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 new file mode 100644 index 000000000..2dbe50341 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a22i.ada @@ -0,0 +1,120 @@ +-- 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 new file mode 100644 index 000000000..89737c746 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a22j.ada @@ -0,0 +1,125 @@ +-- 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 new file mode 100644 index 000000000..2526f7106 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a23a.ada @@ -0,0 +1,221 @@ +-- 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 new file mode 100644 index 000000000..234c7119a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a23e.ada @@ -0,0 +1,198 @@ +-- 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 new file mode 100644 index 000000000..2ec575715 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a24a.ada @@ -0,0 +1,226 @@ +-- 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 new file mode 100644 index 000000000..fcb0087b0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a24e.ada @@ -0,0 +1,220 @@ +-- 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 new file mode 100644 index 000000000..494516bf0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a24i.ada @@ -0,0 +1,126 @@ +-- 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 new file mode 100644 index 000000000..2a9fd8175 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a24j.ada @@ -0,0 +1,124 @@ +-- 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 new file mode 100644 index 000000000..be8efa615 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a31a.ada @@ -0,0 +1,266 @@ +-- 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 new file mode 100644 index 000000000..2b01ed6e2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a31c.ada @@ -0,0 +1,127 @@ +-- 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 new file mode 100644 index 000000000..b4ed17caa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a31e.ada @@ -0,0 +1,139 @@ +-- 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 new file mode 100644 index 000000000..228b445d6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a32a.ada @@ -0,0 +1,272 @@ +-- 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 new file mode 100644 index 000000000..a8edaa6ea --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a32c.ada @@ -0,0 +1,128 @@ +-- 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 new file mode 100644 index 000000000..621ea6749 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a32e.ada @@ -0,0 +1,263 @@ +-- 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 new file mode 100644 index 000000000..c9d84665c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a32g.ada @@ -0,0 +1,131 @@ +-- 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 new file mode 100644 index 000000000..d3439a71e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a32i.ada @@ -0,0 +1,135 @@ +-- 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 new file mode 100644 index 000000000..e8969b3cb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a32j.ada @@ -0,0 +1,135 @@ +-- 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 new file mode 100644 index 000000000..f1ce2886b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a51a.ada @@ -0,0 +1,193 @@ +-- 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 new file mode 100644 index 000000000..15613b5d7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a53a.ada @@ -0,0 +1,217 @@ +-- 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 new file mode 100644 index 000000000..a023967de --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a53e.ada @@ -0,0 +1,235 @@ +-- 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 new file mode 100644 index 000000000..26413daac --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a83c.tst @@ -0,0 +1,101 @@ +-- 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 new file mode 100644 index 000000000..09acce9f4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2a91c.tst @@ -0,0 +1,134 @@ +-- 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 new file mode 100644 index 000000000..580bb8d11 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2b11a.ada @@ -0,0 +1,214 @@ +-- 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 new file mode 100644 index 000000000..770d8d83f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2b11b.ada @@ -0,0 +1,196 @@ +-- 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 new file mode 100644 index 000000000..e620bad74 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2b11d.ada @@ -0,0 +1,54 @@ +-- 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 new file mode 100644 index 000000000..b71f03261 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2b11e.ada @@ -0,0 +1,76 @@ +-- 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 new file mode 100644 index 000000000..ad1564502 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2b11f.ada @@ -0,0 +1,88 @@ +-- 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 new file mode 100644 index 000000000..8e58d81a9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2b15c.ada @@ -0,0 +1,103 @@ +-- 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 new file mode 100644 index 000000000..6dc514186 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2b16a.ada @@ -0,0 +1,85 @@ +-- 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 new file mode 100644 index 000000000..d4f326b99 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2c11a.tst @@ -0,0 +1,140 @@ +--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 new file mode 100644 index 000000000..2e5a5fe9e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2c11d.tst @@ -0,0 +1,87 @@ +--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 new file mode 100644 index 000000000..f44e8ef7d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2d11a.ada @@ -0,0 +1,214 @@ +-- 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 new file mode 100644 index 000000000..abb3f6bcd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd2d13a.ada @@ -0,0 +1,66 @@ +-- 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 new file mode 100644 index 000000000..d65e14508 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd30001.a @@ -0,0 +1,284 @@ +-- 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 new file mode 100644 index 000000000..7b6fff713 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd30002.a @@ -0,0 +1,207 @@ +-- 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 new file mode 100644 index 000000000..af414490f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd30003.a @@ -0,0 +1,227 @@ +-- 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 new file mode 100644 index 000000000..1a1bcff1f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd30004.a @@ -0,0 +1,215 @@ +-- 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 new file mode 100644 index 000000000..81b6e3354 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd300050.am @@ -0,0 +1,154 @@ +-- 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 new file mode 100644 index 000000000..5771fc81b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd300051.c @@ -0,0 +1,57 @@ +/* +-- 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( Value ) + { + /* int Value */ + + return Value + 1; + } + diff --git a/gcc/testsuite/ada/acats/tests/cd/cd3014a.ada b/gcc/testsuite/ada/acats/tests/cd/cd3014a.ada new file mode 100644 index 000000000..ee37df82a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3014a.ada @@ -0,0 +1,132 @@ +-- 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 new file mode 100644 index 000000000..9e8af8980 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3014c.ada @@ -0,0 +1,85 @@ +-- 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 new file mode 100644 index 000000000..6ce3f4ce8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3014d.ada @@ -0,0 +1,135 @@ +-- 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 new file mode 100644 index 000000000..430cc4b2d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3014f.ada @@ -0,0 +1,88 @@ +-- 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 new file mode 100644 index 000000000..34b930db0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3015a.ada @@ -0,0 +1,133 @@ +-- 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 new file mode 100644 index 000000000..c4ed23801 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3015c.ada @@ -0,0 +1,82 @@ +-- 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 new file mode 100644 index 000000000..f0de7be60 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3015e.ada @@ -0,0 +1,130 @@ +-- 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 new file mode 100644 index 000000000..61e93ec49 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3015f.ada @@ -0,0 +1,93 @@ +-- 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 new file mode 100644 index 000000000..9158dc64b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3015g.ada @@ -0,0 +1,136 @@ +-- 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 new file mode 100644 index 000000000..ad557091d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3015h.ada @@ -0,0 +1,86 @@ +-- 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 new file mode 100644 index 000000000..c1cf45b0b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3015i.ada @@ -0,0 +1,144 @@ +-- 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 new file mode 100644 index 000000000..a075f887c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3015k.ada @@ -0,0 +1,92 @@ +-- 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 new file mode 100644 index 000000000..4bad83b61 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd3021a.ada @@ -0,0 +1,66 @@ +-- 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 new file mode 100644 index 000000000..82555054a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd33001.a @@ -0,0 +1,139 @@ +-- 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 new file mode 100644 index 000000000..5b3cdbd5f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd33002.a @@ -0,0 +1,140 @@ +-- 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 new file mode 100644 index 000000000..273271fdb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd40001.a @@ -0,0 +1,181 @@ +-- 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 new file mode 100644 index 000000000..936088d65 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd4031a.ada @@ -0,0 +1,95 @@ +-- 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 new file mode 100644 index 000000000..d0e2fd65d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd4041a.tst @@ -0,0 +1,92 @@ +-- 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 new file mode 100644 index 000000000..746f82bcd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd4051a.ada @@ -0,0 +1,92 @@ +-- 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 new file mode 100644 index 000000000..1cd440f44 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd4051b.ada @@ -0,0 +1,94 @@ +-- 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 new file mode 100644 index 000000000..ea97f1caf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd4051c.ada @@ -0,0 +1,108 @@ +-- 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 new file mode 100644 index 000000000..5b83c336c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd4051d.ada @@ -0,0 +1,134 @@ +-- 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 new file mode 100644 index 000000000..04a7c1a3e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5003a.ada @@ -0,0 +1,79 @@ +-- 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 new file mode 100644 index 000000000..789edd570 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5003b.ada @@ -0,0 +1,77 @@ +-- 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 new file mode 100644 index 000000000..9ea5ae59d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5003c.ada @@ -0,0 +1,86 @@ +-- 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 new file mode 100644 index 000000000..a5a83785c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5003d.ada @@ -0,0 +1,88 @@ +-- 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 new file mode 100644 index 000000000..8c157f832 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5003e.ada @@ -0,0 +1,76 @@ +-- 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 new file mode 100644 index 000000000..1e54c6d24 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5003f.ada @@ -0,0 +1,91 @@ +-- 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 new file mode 100644 index 000000000..5789fec5e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5003g.ada @@ -0,0 +1,89 @@ +-- 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 new file mode 100644 index 000000000..c0418568d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5003h.ada @@ -0,0 +1,89 @@ +-- 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 new file mode 100644 index 000000000..7ea6dc715 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5003i.ada @@ -0,0 +1,94 @@ +-- 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 new file mode 100644 index 000000000..b586f0d9c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5011a.ada @@ -0,0 +1,87 @@ +-- 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 new file mode 100644 index 000000000..45b2490c8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5011c.ada @@ -0,0 +1,69 @@ +-- 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 new file mode 100644 index 000000000..2806fb229 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5011e.ada @@ -0,0 +1,70 @@ +-- 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 new file mode 100644 index 000000000..1b63ba50c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5011g.ada @@ -0,0 +1,72 @@ +-- 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 new file mode 100644 index 000000000..a0a841879 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5011i.ada @@ -0,0 +1,74 @@ +-- 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 new file mode 100644 index 000000000..6c4a16a3e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5011k.ada @@ -0,0 +1,75 @@ +-- 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 new file mode 100644 index 000000000..25d6f856e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5011m.ada @@ -0,0 +1,72 @@ +-- 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 new file mode 100644 index 000000000..4b9bf5c36 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5011q.ada @@ -0,0 +1,91 @@ +-- 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 new file mode 100644 index 000000000..2943892da --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5011s.ada @@ -0,0 +1,89 @@ +-- 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 new file mode 100644 index 000000000..05cb7babd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5012a.ada @@ -0,0 +1,78 @@ +-- 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 new file mode 100644 index 000000000..455fe8564 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5012b.ada @@ -0,0 +1,77 @@ +-- 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 new file mode 100644 index 000000000..bfcd2f545 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5012e.ada @@ -0,0 +1,76 @@ +-- 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 new file mode 100644 index 000000000..69fb2e80b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5012f.ada @@ -0,0 +1,78 @@ +-- 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 new file mode 100644 index 000000000..1be46d425 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5012i.ada @@ -0,0 +1,87 @@ +-- 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 new file mode 100644 index 000000000..1cd3c218e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5012m.ada @@ -0,0 +1,78 @@ +-- 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 new file mode 100644 index 000000000..ad7650e45 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5013a.ada @@ -0,0 +1,72 @@ +-- 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 new file mode 100644 index 000000000..f00dfecb6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5013c.ada @@ -0,0 +1,73 @@ +-- 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 new file mode 100644 index 000000000..cb04cfd62 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5013e.ada @@ -0,0 +1,72 @@ +-- 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 new file mode 100644 index 000000000..355c682c3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5013g.ada @@ -0,0 +1,74 @@ +-- 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 new file mode 100644 index 000000000..7a405b28a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5013i.ada @@ -0,0 +1,73 @@ +-- 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 new file mode 100644 index 000000000..469abf4a5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5013k.ada @@ -0,0 +1,78 @@ +-- 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 new file mode 100644 index 000000000..2e4838606 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5013m.ada @@ -0,0 +1,73 @@ +-- 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 new file mode 100644 index 000000000..c063fcef3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5013o.ada @@ -0,0 +1,83 @@ +-- 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 new file mode 100644 index 000000000..094017798 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5014a.ada @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..d09969f05 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5014c.ada @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..145e3aaf1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5014e.ada @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..28ab3997d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5014g.ada @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..23c235783 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5014i.ada @@ -0,0 +1,83 @@ +-- 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 new file mode 100644 index 000000000..1cee824e9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5014k.ada @@ -0,0 +1,87 @@ +-- 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 new file mode 100644 index 000000000..8b0ec5743 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5014m.ada @@ -0,0 +1,88 @@ +-- 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 new file mode 100644 index 000000000..e8018ca98 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5014o.ada @@ -0,0 +1,85 @@ +-- 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 new file mode 100644 index 000000000..9eee00c71 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5014t.ada @@ -0,0 +1,86 @@ +-- 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 new file mode 100644 index 000000000..237a37a88 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5014v.ada @@ -0,0 +1,83 @@ +-- 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 new file mode 100644 index 000000000..fe6e2cb3b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5014x.ada @@ -0,0 +1,89 @@ +-- 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 new file mode 100644 index 000000000..75c8ba64a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5014y.ada @@ -0,0 +1,74 @@ +-- 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 new file mode 100644 index 000000000..dee329120 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd5014z.ada @@ -0,0 +1,76 @@ +-- 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 new file mode 100644 index 000000000..484009588 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd70001.a @@ -0,0 +1,201 @@ +-- +-- 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 new file mode 100644 index 000000000..f278c0bdd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd7002a.ada @@ -0,0 +1,52 @@ +-- 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 new file mode 100644 index 000000000..c5edf4b22 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd7007b.ada @@ -0,0 +1,52 @@ +-- 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 new file mode 100644 index 000000000..9b56f2c3d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd7101d.ada @@ -0,0 +1,53 @@ +-- 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 new file mode 100644 index 000000000..d2d430a07 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd7101e.dep @@ -0,0 +1,62 @@ +-- 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 new file mode 100644 index 000000000..4f1169eac --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd7101f.dep @@ -0,0 +1,62 @@ +-- 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 new file mode 100644 index 000000000..b91a34d48 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd7101g.tst @@ -0,0 +1,70 @@ +-- 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 new file mode 100644 index 000000000..f6da8a0bb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd7103d.ada @@ -0,0 +1,52 @@ +-- 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 new file mode 100644 index 000000000..8e4f89aef --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd7202a.ada @@ -0,0 +1,55 @@ +-- 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 new file mode 100644 index 000000000..64114ad22 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd7204b.ada @@ -0,0 +1,88 @@ +-- 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 new file mode 100644 index 000000000..77ca9bdb2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd7204c.ada @@ -0,0 +1,91 @@ +-- 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 new file mode 100644 index 000000000..9c98cb0c6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd72a01.a @@ -0,0 +1,165 @@ +-- +-- 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 new file mode 100644 index 000000000..f396edc19 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd72a02.a @@ -0,0 +1,225 @@ +-- 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 new file mode 100644 index 000000000..3241fca8f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd7305a.ada @@ -0,0 +1,52 @@ +-- 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 new file mode 100644 index 000000000..bd5c070a6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd90001.a @@ -0,0 +1,233 @@ +-- 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. +--! + +----------------------------------------------------------------- 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 new file mode 100644 index 000000000..d07ff4881 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cd92001.a @@ -0,0 +1,229 @@ +-- 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 new file mode 100644 index 000000000..b433f0cac --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cda201a.ada @@ -0,0 +1,70 @@ +-- 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 new file mode 100644 index 000000000..742cd92c3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cda201b.ada @@ -0,0 +1,63 @@ +-- 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 new file mode 100644 index 000000000..db742ace7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cda201c.ada @@ -0,0 +1,76 @@ +-- 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 new file mode 100644 index 000000000..c82e48c53 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cda201e.ada @@ -0,0 +1,120 @@ +-- 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 new file mode 100644 index 000000000..566fad138 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cdb0a01.a @@ -0,0 +1,305 @@ +-- 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 new file mode 100644 index 000000000..6a7fca54a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cdb0a02.a @@ -0,0 +1,329 @@ +-- 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 new file mode 100644 index 000000000..3e16f5d4f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cdd1001.a @@ -0,0 +1,94 @@ +-- 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 desginating 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 new file mode 100644 index 000000000..3184dded8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cdd2001.a @@ -0,0 +1,203 @@ +-- 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 new file mode 100644 index 000000000..7c8000ce0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cdd2a01.a @@ -0,0 +1,379 @@ +-- 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 new file mode 100644 index 000000000..854431c34 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cdd2a02.a @@ -0,0 +1,345 @@ +-- 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 new file mode 100644 index 000000000..b4c291772 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cdd2a03.a @@ -0,0 +1,325 @@ +-- 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 new file mode 100644 index 000000000..59db2256f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cd/cde0001.a @@ -0,0 +1,324 @@ +-- 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 new file mode 100644 index 000000000..b784b87de --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102a.ada @@ -0,0 +1,133 @@ +-- 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 new file mode 100644 index 000000000..98494c6cb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102b.ada @@ -0,0 +1,155 @@ +-- 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 new file mode 100644 index 000000000..11868bcca --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102c.tst @@ -0,0 +1,140 @@ +-- 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 new file mode 100644 index 000000000..728eed108 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102d.ada @@ -0,0 +1,63 @@ +-- 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 new file mode 100644 index 000000000..caaf3fd61 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102e.ada @@ -0,0 +1,66 @@ +-- 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 new file mode 100644 index 000000000..8d8328d42 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102f.ada @@ -0,0 +1,65 @@ +-- 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 new file mode 100644 index 000000000..b5de4e617 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102g.ada @@ -0,0 +1,130 @@ +-- 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 new file mode 100644 index 000000000..ea265c034 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102h.tst @@ -0,0 +1,136 @@ +-- 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 new file mode 100644 index 000000000..43616c217 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102i.ada @@ -0,0 +1,63 @@ +-- 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 new file mode 100644 index 000000000..efe08a689 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102j.ada @@ -0,0 +1,66 @@ +-- 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 new file mode 100644 index 000000000..fed673f27 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102k.ada @@ -0,0 +1,248 @@ +-- 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 new file mode 100644 index 000000000..81d86633d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102l.ada @@ -0,0 +1,147 @@ +-- 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 new file mode 100644 index 000000000..8ea79cf9b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102m.ada @@ -0,0 +1,146 @@ +-- 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 new file mode 100644 index 000000000..c7b6414c7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102n.ada @@ -0,0 +1,98 @@ +-- 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 new file mode 100644 index 000000000..699ffa73c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102o.ada @@ -0,0 +1,117 @@ +-- 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 new file mode 100644 index 000000000..f5db1c99a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102p.ada @@ -0,0 +1,98 @@ +-- 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 new file mode 100644 index 000000000..af7fbe564 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102q.ada @@ -0,0 +1,97 @@ +-- 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 new file mode 100644 index 000000000..8ec6c9ec2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102r.ada @@ -0,0 +1,98 @@ +-- 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 new file mode 100644 index 000000000..030ce4925 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102s.ada @@ -0,0 +1,98 @@ +-- 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 new file mode 100644 index 000000000..b97ad627a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102t.ada @@ -0,0 +1,98 @@ +-- 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 new file mode 100644 index 000000000..0a9d946f2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102u.ada @@ -0,0 +1,117 @@ +-- 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 new file mode 100644 index 000000000..423200263 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102v.ada @@ -0,0 +1,98 @@ +-- 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 new file mode 100644 index 000000000..5239f0bc7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102w.ada @@ -0,0 +1,98 @@ +-- 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 new file mode 100644 index 000000000..8f56ac55a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102x.ada @@ -0,0 +1,85 @@ +-- 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 new file mode 100644 index 000000000..e6ae6d3d1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2102y.ada @@ -0,0 +1,83 @@ +-- 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 new file mode 100644 index 000000000..6a6d21a59 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2103a.tst @@ -0,0 +1,142 @@ +-- 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 new file mode 100644 index 000000000..2bcd7ad0b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2103b.tst @@ -0,0 +1,141 @@ +-- 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 new file mode 100644 index 000000000..2f70f3cb9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2103c.ada @@ -0,0 +1,149 @@ +-- 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 new file mode 100644 index 000000000..691650ba3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2103d.ada @@ -0,0 +1,148 @@ +-- 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 new file mode 100644 index 000000000..55e3fc3fd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2104a.ada @@ -0,0 +1,118 @@ +-- 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 new file mode 100644 index 000000000..000d00bc8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2104b.ada @@ -0,0 +1,125 @@ +-- 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 new file mode 100644 index 000000000..840eb575f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2104c.ada @@ -0,0 +1,115 @@ +-- 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 new file mode 100644 index 000000000..068826da1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2104d.ada @@ -0,0 +1,126 @@ +-- 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 new file mode 100644 index 000000000..0facea571 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2106a.ada @@ -0,0 +1,122 @@ +-- 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 new file mode 100644 index 000000000..da6bc8cfe --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2106b.ada @@ -0,0 +1,119 @@ +-- 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 new file mode 100644 index 000000000..d03dd2d3f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2108e.ada @@ -0,0 +1,83 @@ +-- 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 new file mode 100644 index 000000000..7f88abd01 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2108f.ada @@ -0,0 +1,112 @@ +-- 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 new file mode 100644 index 000000000..81166569d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2108g.ada @@ -0,0 +1,82 @@ +-- 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 new file mode 100644 index 000000000..483f23e0b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2108h.ada @@ -0,0 +1,108 @@ +-- 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 new file mode 100644 index 000000000..5d25a59d7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2109a.ada @@ -0,0 +1,83 @@ +-- 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 new file mode 100644 index 000000000..5d17489f5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2109b.ada @@ -0,0 +1,80 @@ +-- 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 new file mode 100644 index 000000000..9d4f3bb0a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2109c.ada @@ -0,0 +1,76 @@ +-- 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 new file mode 100644 index 000000000..f71bbfe07 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2110a.ada @@ -0,0 +1,104 @@ +-- 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 new file mode 100644 index 000000000..983657ad5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2110c.ada @@ -0,0 +1,104 @@ +-- 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 new file mode 100644 index 000000000..c71591a89 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2111a.ada @@ -0,0 +1,131 @@ +-- 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 new file mode 100644 index 000000000..58ceb832c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2111b.ada @@ -0,0 +1,183 @@ +-- 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 new file mode 100644 index 000000000..09aff6657 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2111c.ada @@ -0,0 +1,127 @@ +-- 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 new file mode 100644 index 000000000..57e4cb89f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2111e.ada @@ -0,0 +1,156 @@ +-- 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 new file mode 100644 index 000000000..1259cb894 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2111f.ada @@ -0,0 +1,132 @@ +-- 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 new file mode 100644 index 000000000..c3375482f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2111g.ada @@ -0,0 +1,147 @@ +-- 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 new file mode 100644 index 000000000..d9367f5ad --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2111i.ada @@ -0,0 +1,113 @@ +-- 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 new file mode 100644 index 000000000..85c188fac --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2201a.ada @@ -0,0 +1,112 @@ +-- 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 new file mode 100644 index 000000000..151f88663 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2201b.ada @@ -0,0 +1,116 @@ +-- 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 new file mode 100644 index 000000000..44516b172 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2201c.ada @@ -0,0 +1,111 @@ +-- 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 new file mode 100644 index 000000000..fdbe40e59 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2201d.dep @@ -0,0 +1,145 @@ +-- 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 new file mode 100644 index 000000000..2ee9578dd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2201e.dep @@ -0,0 +1,155 @@ +-- 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 new file mode 100644 index 000000000..7baa401e6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2201f.ada @@ -0,0 +1,129 @@ +-- 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 new file mode 100644 index 000000000..cb8a528d7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2201g.ada @@ -0,0 +1,138 @@ +-- 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 new file mode 100644 index 000000000..03705c8d6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2201h.ada @@ -0,0 +1,105 @@ +-- 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 new file mode 100644 index 000000000..e3e6e6037 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2201i.ada @@ -0,0 +1,105 @@ +-- 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 new file mode 100644 index 000000000..060909c4a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2201j.ada @@ -0,0 +1,106 @@ +-- 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 new file mode 100644 index 000000000..a372ad602 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2201k.ada @@ -0,0 +1,102 @@ +-- 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 new file mode 100644 index 000000000..15af84035 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2201l.ada @@ -0,0 +1,103 @@ +-- 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 new file mode 100644 index 000000000..cf32381bf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2201m.ada @@ -0,0 +1,123 @@ +-- 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 new file mode 100644 index 000000000..2eaa296e2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2201n.ada @@ -0,0 +1,123 @@ +-- 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 new file mode 100644 index 000000000..a4073579b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2202a.ada @@ -0,0 +1,143 @@ +-- 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 new file mode 100644 index 000000000..f9a3f658d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2203a.tst @@ -0,0 +1,121 @@ +-- 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 new file mode 100644 index 000000000..ee6089878 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2204a.ada @@ -0,0 +1,117 @@ +-- 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 new file mode 100644 index 000000000..61ef0abe6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2204b.ada @@ -0,0 +1,118 @@ +-- 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 new file mode 100644 index 000000000..5981d38df --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2204c.ada @@ -0,0 +1,91 @@ +-- 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 new file mode 100644 index 000000000..38427f5bc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2204d.ada @@ -0,0 +1,104 @@ +-- 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 new file mode 100644 index 000000000..33edc2d68 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2205a.ada @@ -0,0 +1,151 @@ +-- 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 new file mode 100644 index 000000000..841b680dd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2206a.ada @@ -0,0 +1,133 @@ +-- 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 new file mode 100644 index 000000000..418199a86 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2208b.ada @@ -0,0 +1,185 @@ +-- 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 new file mode 100644 index 000000000..4ec422769 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2401a.ada @@ -0,0 +1,357 @@ +-- 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 new file mode 100644 index 000000000..e527fbb56 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2401b.ada @@ -0,0 +1,347 @@ +-- 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 new file mode 100644 index 000000000..d793104a7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2401c.ada @@ -0,0 +1,268 @@ +-- 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 new file mode 100644 index 000000000..a9b050d7c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2401e.ada @@ -0,0 +1,172 @@ +-- 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 new file mode 100644 index 000000000..30b69c991 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2401f.ada @@ -0,0 +1,200 @@ +-- 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 new file mode 100644 index 000000000..70ce088d5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2401h.ada @@ -0,0 +1,168 @@ +-- 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 new file mode 100644 index 000000000..68f2ba439 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2401i.ada @@ -0,0 +1,163 @@ +-- 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 new file mode 100644 index 000000000..85e43cc66 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2401j.ada @@ -0,0 +1,176 @@ +-- 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 new file mode 100644 index 000000000..2e00f66ef --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2401k.ada @@ -0,0 +1,164 @@ +-- 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 new file mode 100644 index 000000000..3ecba26fc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2401l.ada @@ -0,0 +1,125 @@ +-- 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 new file mode 100644 index 000000000..f05330a34 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2402a.ada @@ -0,0 +1,161 @@ +-- 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 new file mode 100644 index 000000000..0988eb256 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2403a.tst @@ -0,0 +1,121 @@ +-- 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 new file mode 100644 index 000000000..11bec0f33 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2404a.ada @@ -0,0 +1,99 @@ +-- 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 new file mode 100644 index 000000000..8e3d56077 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2404b.ada @@ -0,0 +1,82 @@ +-- 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 new file mode 100644 index 000000000..fb8224282 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2405b.ada @@ -0,0 +1,157 @@ +-- 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 new file mode 100644 index 000000000..3fbf03781 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2406a.ada @@ -0,0 +1,199 @@ +-- 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 new file mode 100644 index 000000000..ce55310db --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2407a.ada @@ -0,0 +1,110 @@ +-- 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 new file mode 100644 index 000000000..b97b76160 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2407b.ada @@ -0,0 +1,93 @@ +-- 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 new file mode 100644 index 000000000..a6cf7d3b4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2408a.ada @@ -0,0 +1,120 @@ +-- 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 new file mode 100644 index 000000000..7c2da6bb8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2408b.ada @@ -0,0 +1,112 @@ +-- 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 new file mode 100644 index 000000000..e6e591f0e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2409a.ada @@ -0,0 +1,113 @@ +-- 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 new file mode 100644 index 000000000..544819864 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2409b.ada @@ -0,0 +1,98 @@ +-- 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 new file mode 100644 index 000000000..5029d1ec6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2410a.ada @@ -0,0 +1,96 @@ +-- 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 new file mode 100644 index 000000000..665bc8efc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2410b.ada @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..9f735df68 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce2411a.ada @@ -0,0 +1,207 @@ +-- 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 new file mode 100644 index 000000000..7dcc28fe0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3002b.tst @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..c240907f8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3002c.tst @@ -0,0 +1,69 @@ +-- 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 new file mode 100644 index 000000000..3d1976014 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3002d.ada @@ -0,0 +1,61 @@ +-- 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 new file mode 100644 index 000000000..ad15ecdee --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3002f.ada @@ -0,0 +1,55 @@ +-- 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 new file mode 100644 index 000000000..ec5c5001d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3102a.ada @@ -0,0 +1,151 @@ +-- 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 new file mode 100644 index 000000000..2383d45d8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3102b.tst @@ -0,0 +1,184 @@ +-- 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 new file mode 100644 index 000000000..0f58c1976 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3102d.ada @@ -0,0 +1,145 @@ +-- 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 new file mode 100644 index 000000000..c971abd48 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3102e.ada @@ -0,0 +1,63 @@ +-- 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 new file mode 100644 index 000000000..d87b80ae4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3102f.ada @@ -0,0 +1,130 @@ +-- 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 new file mode 100644 index 000000000..a60f50f22 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3102g.ada @@ -0,0 +1,84 @@ +-- 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 new file mode 100644 index 000000000..152b6eabc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3102h.ada @@ -0,0 +1,116 @@ +-- 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 new file mode 100644 index 000000000..cc126bc7e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3102i.ada @@ -0,0 +1,63 @@ +-- 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 new file mode 100644 index 000000000..ce1b5f689 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3102j.ada @@ -0,0 +1,98 @@ +-- 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 new file mode 100644 index 000000000..151a4d687 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3102k.ada @@ -0,0 +1,98 @@ +-- 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 new file mode 100644 index 000000000..7b09a7727 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3103a.ada @@ -0,0 +1,216 @@ +-- 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 new file mode 100644 index 000000000..4725f2473 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3104a.ada @@ -0,0 +1,231 @@ +-- 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 new file mode 100644 index 000000000..34af98936 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3104b.ada @@ -0,0 +1,120 @@ +-- 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 new file mode 100644 index 000000000..a9379ef42 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3104c.ada @@ -0,0 +1,117 @@ +-- 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 new file mode 100644 index 000000000..474a66ade --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3106a.ada @@ -0,0 +1,226 @@ +-- 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 new file mode 100644 index 000000000..9d507a97c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3106b.ada @@ -0,0 +1,220 @@ +-- 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 new file mode 100644 index 000000000..96646fb71 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3107a.tst @@ -0,0 +1,135 @@ +-- 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 new file mode 100644 index 000000000..6c40c5d60 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3107b.ada @@ -0,0 +1,141 @@ +-- 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 new file mode 100644 index 000000000..f5297a60a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3108a.ada @@ -0,0 +1,106 @@ +-- 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 new file mode 100644 index 000000000..0c366f6ab --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3108b.ada @@ -0,0 +1,111 @@ +-- 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 new file mode 100644 index 000000000..f6d756a75 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3110a.ada @@ -0,0 +1,107 @@ +-- 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 new file mode 100644 index 000000000..3ee20cf1b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3112c.ada @@ -0,0 +1,81 @@ +-- 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 new file mode 100644 index 000000000..3328c8161 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3112d.ada @@ -0,0 +1,112 @@ +-- 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 new file mode 100644 index 000000000..f217cde6a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3114a.ada @@ -0,0 +1,102 @@ +-- 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 new file mode 100644 index 000000000..66d951e53 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3115a.ada @@ -0,0 +1,232 @@ +-- 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 new file mode 100644 index 000000000..eb7b6ead4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3201a.ada @@ -0,0 +1,71 @@ +-- 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 new file mode 100644 index 000000000..755d48850 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3202a.ada @@ -0,0 +1,57 @@ +-- 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 new file mode 100644 index 000000000..a865b6091 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3206a.ada @@ -0,0 +1,103 @@ +-- 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 new file mode 100644 index 000000000..6b234cef0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3207a.ada @@ -0,0 +1,107 @@ +-- 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 new file mode 100644 index 000000000..4766cb9c0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3301a.ada @@ -0,0 +1,176 @@ +-- 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 new file mode 100644 index 000000000..905da7abe --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3302a.ada @@ -0,0 +1,138 @@ +-- 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 new file mode 100644 index 000000000..50facadb9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3303a.ada @@ -0,0 +1,152 @@ +-- 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 new file mode 100644 index 000000000..e1ee3f859 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3304a.tst @@ -0,0 +1,204 @@ +-- 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 new file mode 100644 index 000000000..1807d9128 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3305a.ada @@ -0,0 +1,182 @@ +-- 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 new file mode 100644 index 000000000..c021f3147 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3306a.ada @@ -0,0 +1,82 @@ +-- 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 new file mode 100644 index 000000000..714e16c03 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3401a.ada @@ -0,0 +1,105 @@ +-- 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 new file mode 100644 index 000000000..18773f848 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3402a.ada @@ -0,0 +1,117 @@ +-- 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 new file mode 100644 index 000000000..ed5d27b1b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3402c.ada @@ -0,0 +1,112 @@ +-- 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 new file mode 100644 index 000000000..a52c7dea6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3402d.ada @@ -0,0 +1,92 @@ +-- 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 new file mode 100644 index 000000000..7b498795a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3402e.ada @@ -0,0 +1,106 @@ +-- 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 new file mode 100644 index 000000000..67ed44c7d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3403a.ada @@ -0,0 +1,109 @@ +-- 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 new file mode 100644 index 000000000..5cae13d47 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3403b.ada @@ -0,0 +1,152 @@ +-- 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 new file mode 100644 index 000000000..d6dd6586a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3403c.ada @@ -0,0 +1,122 @@ +-- 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 new file mode 100644 index 000000000..6fc1a2532 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3403d.ada @@ -0,0 +1,99 @@ +-- 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 new file mode 100644 index 000000000..3d324a72c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3403e.ada @@ -0,0 +1,150 @@ +-- 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 new file mode 100644 index 000000000..ebd6420f5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3403f.ada @@ -0,0 +1,156 @@ +-- 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 new file mode 100644 index 000000000..a944138ec --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3404a.ada @@ -0,0 +1,94 @@ +-- 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 new file mode 100644 index 000000000..87ae4b166 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3404b.ada @@ -0,0 +1,130 @@ +-- 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 new file mode 100644 index 000000000..c03cf557a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3404c.ada @@ -0,0 +1,165 @@ +-- 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 new file mode 100644 index 000000000..33e1f725b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3404d.ada @@ -0,0 +1,152 @@ +-- 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 new file mode 100644 index 000000000..d035af7ce --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3405a.ada @@ -0,0 +1,127 @@ +-- 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 new file mode 100644 index 000000000..27f157440 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3405c.ada @@ -0,0 +1,126 @@ +-- 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 new file mode 100644 index 000000000..b21fb1df6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3405d.ada @@ -0,0 +1,114 @@ +-- 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 new file mode 100644 index 000000000..14765189f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3406a.ada @@ -0,0 +1,159 @@ +-- 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 new file mode 100644 index 000000000..95e7c7adb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3406b.ada @@ -0,0 +1,104 @@ +-- 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 new file mode 100644 index 000000000..bc3027429 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3406c.ada @@ -0,0 +1,148 @@ +-- 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 new file mode 100644 index 000000000..fa1ba25f0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3406d.ada @@ -0,0 +1,122 @@ +-- 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 new file mode 100644 index 000000000..d3a0052f2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3407a.ada @@ -0,0 +1,141 @@ +-- 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 new file mode 100644 index 000000000..c4a509c3d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3407b.ada @@ -0,0 +1,107 @@ +-- 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 new file mode 100644 index 000000000..7be1f47c4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3407c.ada @@ -0,0 +1,134 @@ +-- 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 new file mode 100644 index 000000000..2b0107e5a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3408a.ada @@ -0,0 +1,142 @@ +-- 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 new file mode 100644 index 000000000..a8269f7ab --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3408b.ada @@ -0,0 +1,109 @@ +-- 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 new file mode 100644 index 000000000..db74ac5bc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3408c.ada @@ -0,0 +1,138 @@ +-- 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 new file mode 100644 index 000000000..6dd5d1cc9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3409a.ada @@ -0,0 +1,111 @@ +-- 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 new file mode 100644 index 000000000..1af3f07f5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3409b.ada @@ -0,0 +1,76 @@ +-- 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 new file mode 100644 index 000000000..7085884a9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3409c.ada @@ -0,0 +1,188 @@ +-- 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 new file mode 100644 index 000000000..97ecd9b03 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3409d.ada @@ -0,0 +1,140 @@ +-- 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 new file mode 100644 index 000000000..28d072d7a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3409e.ada @@ -0,0 +1,115 @@ +-- 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 new file mode 100644 index 000000000..a4e3870af --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3410a.ada @@ -0,0 +1,89 @@ +-- 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 new file mode 100644 index 000000000..08f185fc8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3410b.ada @@ -0,0 +1,77 @@ +-- 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 new file mode 100644 index 000000000..dc004895d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3410c.ada @@ -0,0 +1,205 @@ +-- 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 new file mode 100644 index 000000000..09fa09ebc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3410d.ada @@ -0,0 +1,118 @@ +-- 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 new file mode 100644 index 000000000..f86608bf5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3410e.ada @@ -0,0 +1,125 @@ +-- 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 new file mode 100644 index 000000000..1b81316d1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3411a.ada @@ -0,0 +1,164 @@ +-- 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 new file mode 100644 index 000000000..fd95831c6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3411c.ada @@ -0,0 +1,146 @@ +-- 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 new file mode 100644 index 000000000..56b6744a4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3412a.ada @@ -0,0 +1,149 @@ +-- 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 new file mode 100644 index 000000000..079da5edd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3413a.ada @@ -0,0 +1,128 @@ +-- 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 new file mode 100644 index 000000000..cb273caa3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3413b.ada @@ -0,0 +1,163 @@ +-- 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 new file mode 100644 index 000000000..dca4c2ba6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3413c.ada @@ -0,0 +1,152 @@ +-- 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 new file mode 100644 index 000000000..8f236ca2f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3414a.ada @@ -0,0 +1,204 @@ +-- 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 new file mode 100644 index 000000000..c5b63fd61 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3601a.ada @@ -0,0 +1,187 @@ +-- 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 new file mode 100644 index 000000000..ff0280303 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3602a.ada @@ -0,0 +1,189 @@ +-- 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 new file mode 100644 index 000000000..71482425a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3602b.ada @@ -0,0 +1,215 @@ +-- 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 new file mode 100644 index 000000000..153fed7f8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3602c.ada @@ -0,0 +1,202 @@ +-- 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 new file mode 100644 index 000000000..89b6a47ad --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3602d.ada @@ -0,0 +1,150 @@ +-- 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 new file mode 100644 index 000000000..d9d4f1e6d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3603a.ada @@ -0,0 +1,217 @@ +-- 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 new file mode 100644 index 000000000..380791f09 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3604a.ada @@ -0,0 +1,160 @@ +-- 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 new file mode 100644 index 000000000..5684b8af6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3604b.ada @@ -0,0 +1,137 @@ +-- 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 new file mode 100644 index 000000000..41d1eae91 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3605a.ada @@ -0,0 +1,118 @@ +-- 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 new file mode 100644 index 000000000..c0de3c571 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3605b.ada @@ -0,0 +1,142 @@ +-- 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 new file mode 100644 index 000000000..7dca9781f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3605c.ada @@ -0,0 +1,159 @@ +-- 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 new file mode 100644 index 000000000..1d52eae79 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3605d.ada @@ -0,0 +1,192 @@ +-- 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 new file mode 100644 index 000000000..5ea6f236d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3605e.ada @@ -0,0 +1,103 @@ +-- 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 new file mode 100644 index 000000000..18b2af8ca --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3606a.ada @@ -0,0 +1,91 @@ +-- 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 new file mode 100644 index 000000000..728a256cd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3606b.ada @@ -0,0 +1,97 @@ +-- 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 new file mode 100644 index 000000000..0f9c52f49 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3701a.ada @@ -0,0 +1,109 @@ +-- 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 new file mode 100644 index 000000000..f2325c04b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3704a.ada @@ -0,0 +1,134 @@ +-- 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 new file mode 100644 index 000000000..59f60c4a5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3704b.ada @@ -0,0 +1,107 @@ +-- 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 new file mode 100644 index 000000000..b3567fae7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3704c.ada @@ -0,0 +1,176 @@ +-- 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 new file mode 100644 index 000000000..233b8642a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3704d.ada @@ -0,0 +1,169 @@ +-- 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 new file mode 100644 index 000000000..6fb043079 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3704e.ada @@ -0,0 +1,143 @@ +-- 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 new file mode 100644 index 000000000..22f021712 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3704f.ada @@ -0,0 +1,365 @@ +-- 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 new file mode 100644 index 000000000..2d6d3d4be --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3704m.ada @@ -0,0 +1,198 @@ +-- 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 new file mode 100644 index 000000000..656b45a96 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3704n.ada @@ -0,0 +1,229 @@ +-- 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 new file mode 100644 index 000000000..f38b1e9b7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3704o.ada @@ -0,0 +1,161 @@ +-- 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 new file mode 100644 index 000000000..8cd848e4c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3705a.ada @@ -0,0 +1,109 @@ +-- 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 new file mode 100644 index 000000000..a0357e366 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3705b.ada @@ -0,0 +1,144 @@ +-- 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 new file mode 100644 index 000000000..a9706da39 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3705c.ada @@ -0,0 +1,137 @@ +-- 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 new file mode 100644 index 000000000..b9af594df --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3705d.ada @@ -0,0 +1,124 @@ +-- 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 new file mode 100644 index 000000000..22798b534 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3705e.ada @@ -0,0 +1,124 @@ +-- 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 new file mode 100644 index 000000000..b7cdd1626 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3706c.ada @@ -0,0 +1,164 @@ +-- 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 new file mode 100644 index 000000000..3696af3e7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3706d.ada @@ -0,0 +1,127 @@ +-- 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 new file mode 100644 index 000000000..833332e3a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3706f.ada @@ -0,0 +1,119 @@ +-- 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 new file mode 100644 index 000000000..705c215ec --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3706g.ada @@ -0,0 +1,111 @@ +-- 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 new file mode 100644 index 000000000..a338fbf8d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3707a.ada @@ -0,0 +1,130 @@ +-- 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 new file mode 100644 index 000000000..104bc20c7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3708a.ada @@ -0,0 +1,87 @@ +-- 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 new file mode 100644 index 000000000..027093632 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3801a.ada @@ -0,0 +1,112 @@ +-- 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 new file mode 100644 index 000000000..1eb3a8e7a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3801b.ada @@ -0,0 +1,108 @@ +-- 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 new file mode 100644 index 000000000..c05a1ff1a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3804a.ada @@ -0,0 +1,157 @@ +-- 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 new file mode 100644 index 000000000..c677d7ea3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3804b.ada @@ -0,0 +1,147 @@ +-- 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 new file mode 100644 index 000000000..b2be751cc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3804c.ada @@ -0,0 +1,121 @@ +-- 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 new file mode 100644 index 000000000..5187f8ff7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3804d.ada @@ -0,0 +1,153 @@ +-- 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 new file mode 100644 index 000000000..021baba2d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3804e.ada @@ -0,0 +1,154 @@ +-- 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 new file mode 100644 index 000000000..96a48d858 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3804f.ada @@ -0,0 +1,206 @@ +-- 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 new file mode 100644 index 000000000..e88e9dc2f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3804g.ada @@ -0,0 +1,167 @@ +-- 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 new file mode 100644 index 000000000..6f7d87cb2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3804h.ada @@ -0,0 +1,161 @@ +-- 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 new file mode 100644 index 000000000..19e292fd3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3804i.ada @@ -0,0 +1,141 @@ +-- 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 new file mode 100644 index 000000000..a7d4c841a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3804j.ada @@ -0,0 +1,137 @@ +-- 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 new file mode 100644 index 000000000..d71d2fccc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3804m.ada @@ -0,0 +1,157 @@ +-- 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 new file mode 100644 index 000000000..a08e2c972 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3804o.ada @@ -0,0 +1,121 @@ +-- 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 new file mode 100644 index 000000000..d4afd2a49 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3804p.ada @@ -0,0 +1,206 @@ +-- 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 new file mode 100644 index 000000000..74c8aff09 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3805a.ada @@ -0,0 +1,162 @@ +-- 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 new file mode 100644 index 000000000..80919630e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3805b.ada @@ -0,0 +1,163 @@ +-- 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 new file mode 100644 index 000000000..09762f319 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3806a.ada @@ -0,0 +1,132 @@ +-- 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 new file mode 100644 index 000000000..194f1a971 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3806b.ada @@ -0,0 +1,124 @@ +-- 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 new file mode 100644 index 000000000..6a7a79338 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3806c.ada @@ -0,0 +1,197 @@ +-- 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 new file mode 100644 index 000000000..6189ef14f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3806d.ada @@ -0,0 +1,129 @@ +-- 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 new file mode 100644 index 000000000..4865020f7 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3806e.ada @@ -0,0 +1,159 @@ +-- 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 new file mode 100644 index 000000000..e013bbb5e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3806f.ada @@ -0,0 +1,194 @@ +-- 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 new file mode 100644 index 000000000..edfcf6a4b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3806g.ada @@ -0,0 +1,125 @@ +-- 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 new file mode 100644 index 000000000..daaef6a9e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3806h.ada @@ -0,0 +1,144 @@ +-- 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 new file mode 100644 index 000000000..f854553fd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3809a.ada @@ -0,0 +1,239 @@ +-- 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 new file mode 100644 index 000000000..45aca867e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3809b.ada @@ -0,0 +1,239 @@ +-- 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 new file mode 100644 index 000000000..f51728c43 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3810a.ada @@ -0,0 +1,114 @@ +-- 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 new file mode 100644 index 000000000..dfdbd56c0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3810b.ada @@ -0,0 +1,122 @@ +-- 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 new file mode 100644 index 000000000..196ff86cc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3815a.ada @@ -0,0 +1,103 @@ +-- 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 new file mode 100644 index 000000000..1760dd976 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3901a.ada @@ -0,0 +1,106 @@ +-- 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 new file mode 100644 index 000000000..9f5359949 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3902b.ada @@ -0,0 +1,117 @@ +-- 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 new file mode 100644 index 000000000..7fe900b6d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3904a.ada @@ -0,0 +1,117 @@ +-- 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 new file mode 100644 index 000000000..408e5909c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3904b.ada @@ -0,0 +1,142 @@ +-- 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 new file mode 100644 index 000000000..4fa69ef61 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3905a.ada @@ -0,0 +1,145 @@ +-- 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 new file mode 100644 index 000000000..5823f2962 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3905b.ada @@ -0,0 +1,111 @@ +-- 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 new file mode 100644 index 000000000..226abb9bc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3905c.ada @@ -0,0 +1,202 @@ +-- 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 new file mode 100644 index 000000000..759c7de6f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3905l.ada @@ -0,0 +1,311 @@ +-- 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 new file mode 100644 index 000000000..a2dc87925 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3906a.ada @@ -0,0 +1,110 @@ +-- 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 new file mode 100644 index 000000000..3e0234084 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3906b.ada @@ -0,0 +1,133 @@ +-- 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 new file mode 100644 index 000000000..0cf93a451 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3906c.ada @@ -0,0 +1,177 @@ +-- 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 new file mode 100644 index 000000000..954b4f8df --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3906d.ada @@ -0,0 +1,152 @@ +-- 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 new file mode 100644 index 000000000..29ac3ea7b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3906e.ada @@ -0,0 +1,109 @@ +-- 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 new file mode 100644 index 000000000..484514b73 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3906f.ada @@ -0,0 +1,102 @@ +-- 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 new file mode 100644 index 000000000..0765c4277 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3907a.ada @@ -0,0 +1,75 @@ +-- 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 new file mode 100644 index 000000000..44c3954da --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ce/ce3908a.ada @@ -0,0 +1,140 @@ +-- 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 new file mode 100644 index 000000000..9c7e25b97 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa3001.a @@ -0,0 +1,507 @@ +-- 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 new file mode 100644 index 000000000..12d98fdfe --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa3002.a @@ -0,0 +1,318 @@ +-- 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 new file mode 100644 index 000000000..f469ef8b5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa3003.a @@ -0,0 +1,243 @@ +-- 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/cxa4001.a b/gcc/testsuite/ada/acats/tests/cxa/cxa4001.a new file mode 100644 index 000000000..d850acd4a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4001.a @@ -0,0 +1,218 @@ +-- 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"); + 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"); + 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 new file mode 100644 index 000000000..583621ab4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4002.a @@ -0,0 +1,182 @@ +-- 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 new file mode 100644 index 000000000..cd57a9296 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4003.a @@ -0,0 +1,326 @@ +-- 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 new file mode 100644 index 000000000..ec11f7d50 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4004.a @@ -0,0 +1,431 @@ +-- 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 new file mode 100644 index 000000000..d61f853ca --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4005.a @@ -0,0 +1,683 @@ +-- 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 new file mode 100644 index 000000000..e1d7f46f5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4006.a @@ -0,0 +1,319 @@ +-- 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 new file mode 100644 index 000000000..fca15d367 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4007.a @@ -0,0 +1,334 @@ +-- 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 new file mode 100644 index 000000000..629305f76 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4008.a @@ -0,0 +1,662 @@ +-- 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 new file mode 100644 index 000000000..f02ef0365 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4009.a @@ -0,0 +1,619 @@ +-- 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 new file mode 100644 index 000000000..8646b12b5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4010.a @@ -0,0 +1,275 @@ +-- 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 new file mode 100644 index 000000000..05388a04b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4011.a @@ -0,0 +1,376 @@ +-- 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 new file mode 100644 index 000000000..5ab12b6df --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4012.a @@ -0,0 +1,305 @@ +-- 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 new file mode 100644 index 000000000..0f93e9dc8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4013.a @@ -0,0 +1,203 @@ +-- 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 new file mode 100644 index 000000000..6e26a0330 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4014.a @@ -0,0 +1,359 @@ +-- 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 new file mode 100644 index 000000000..83fad3af8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4015.a @@ -0,0 +1,580 @@ +-- 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 new file mode 100644 index 000000000..00dcdcdbd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4016.a @@ -0,0 +1,685 @@ +-- 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 new file mode 100644 index 000000000..8d6886897 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4017.a @@ -0,0 +1,337 @@ +-- 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 new file mode 100644 index 000000000..98e0ded4a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4018.a @@ -0,0 +1,379 @@ +-- 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 new file mode 100644 index 000000000..943e3e73b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4019.a @@ -0,0 +1,1027 @@ +-- 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 new file mode 100644 index 000000000..24036f171 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4020.a @@ -0,0 +1,688 @@ +-- 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 new file mode 100644 index 000000000..345a77c68 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4021.a @@ -0,0 +1,311 @@ +-- 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 new file mode 100644 index 000000000..3c649a1a2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4022.a @@ -0,0 +1,531 @@ +-- 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 new file mode 100644 index 000000000..d0325fc88 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4023.a @@ -0,0 +1,585 @@ +-- 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 new file mode 100644 index 000000000..1b0af9ce9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4024.a @@ -0,0 +1,350 @@ +-- 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 new file mode 100644 index 000000000..1665f7a46 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4025.a @@ -0,0 +1,376 @@ +-- 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 new file mode 100644 index 000000000..766979ad0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4026.a @@ -0,0 +1,526 @@ +-- 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 new file mode 100644 index 000000000..05c66d4cc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4027.a @@ -0,0 +1,342 @@ +-- 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 new file mode 100644 index 000000000..bc6cac14c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4028.a @@ -0,0 +1,331 @@ +-- 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 new file mode 100644 index 000000000..714067454 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4029.a @@ -0,0 +1,333 @@ +-- 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 new file mode 100644 index 000000000..475d00899 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4030.a @@ -0,0 +1,414 @@ +-- 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 new file mode 100644 index 000000000..91bc68ce6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4031.a @@ -0,0 +1,291 @@ +-- 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 new file mode 100644 index 000000000..031d01c6c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4032.a @@ -0,0 +1,457 @@ +-- 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 new file mode 100644 index 000000000..8f39b4cff --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4033.a @@ -0,0 +1,405 @@ +-- 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 new file mode 100644 index 000000000..a1ed53de0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa4034.a @@ -0,0 +1,281 @@ +-- 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 new file mode 100644 index 000000000..c9a007e52 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5011.a @@ -0,0 +1,471 @@ +-- 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 new file mode 100644 index 000000000..a286fa71e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5012.a @@ -0,0 +1,536 @@ +-- 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/cxa5015.a b/gcc/testsuite/ada/acats/tests/cxa/cxa5015.a new file mode 100644 index 000000000..e1035db27 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5015.a @@ -0,0 +1,342 @@ +-- 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 new file mode 100644 index 000000000..12db5e7e1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5a01.a @@ -0,0 +1,338 @@ +-- 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 new file mode 100644 index 000000000..9e6c575dd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5a02.a @@ -0,0 +1,328 @@ +-- 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 new file mode 100644 index 000000000..d99ba9bdc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5a03.a @@ -0,0 +1,426 @@ +-- 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 new file mode 100644 index 000000000..9b590a23c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5a04.a @@ -0,0 +1,434 @@ +-- 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 new file mode 100644 index 000000000..b50da3a6a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5a05.a @@ -0,0 +1,338 @@ +-- 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 new file mode 100644 index 000000000..191a96d75 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5a06.a @@ -0,0 +1,334 @@ +-- 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 new file mode 100644 index 000000000..179d54c44 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5a07.a @@ -0,0 +1,413 @@ +-- 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 new file mode 100644 index 000000000..ae2b85a6d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5a08.a @@ -0,0 +1,474 @@ +-- 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 new file mode 100644 index 000000000..22bd2f890 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5a09.a @@ -0,0 +1,400 @@ +-- 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 new file mode 100644 index 000000000..4804d6729 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa5a10.a @@ -0,0 +1,551 @@ +-- 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 new file mode 100644 index 000000000..16f30752d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa8001.a @@ -0,0 +1,243 @@ +-- 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 new file mode 100644 index 000000000..8670e98ba --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa8002.a @@ -0,0 +1,285 @@ +-- 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 new file mode 100644 index 000000000..cf9b5e075 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa8003.a @@ -0,0 +1,214 @@ +-- 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 new file mode 100644 index 000000000..4fe9c3576 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa9001.a @@ -0,0 +1,287 @@ +-- 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 new file mode 100644 index 000000000..415a56630 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxa9002.a @@ -0,0 +1,482 @@ +-- 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 new file mode 100644 index 000000000..6c2af9870 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa001.a @@ -0,0 +1,279 @@ +-- 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 new file mode 100644 index 000000000..953d33f1d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa002.a @@ -0,0 +1,257 @@ +-- 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 new file mode 100644 index 000000000..c9580dfb3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa003.a @@ -0,0 +1,293 @@ +-- 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 new file mode 100644 index 000000000..f3ea17eba --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa004.a @@ -0,0 +1,260 @@ +-- 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 new file mode 100644 index 000000000..7b2a0bc39 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa005.a @@ -0,0 +1,292 @@ +-- 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 new file mode 100644 index 000000000..518d43b89 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa006.a @@ -0,0 +1,285 @@ +-- 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 new file mode 100644 index 000000000..fe79c2d7a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa007.a @@ -0,0 +1,263 @@ +-- 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 new file mode 100644 index 000000000..c21d07ea9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa008.a @@ -0,0 +1,271 @@ +-- 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 new file mode 100644 index 000000000..d47806080 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa009.a @@ -0,0 +1,290 @@ +-- 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 new file mode 100644 index 000000000..5678aee6b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa010.a @@ -0,0 +1,335 @@ +-- 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 new file mode 100644 index 000000000..8cc136d35 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa011.a @@ -0,0 +1,266 @@ +-- 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 new file mode 100644 index 000000000..07523b441 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa012.a @@ -0,0 +1,167 @@ +-- 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 new file mode 100644 index 000000000..be658ca13 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa013.a @@ -0,0 +1,167 @@ +-- 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 new file mode 100644 index 000000000..0b74c6169 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa014.a @@ -0,0 +1,178 @@ +-- 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 new file mode 100644 index 000000000..919ef05ca --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa015.a @@ -0,0 +1,227 @@ +-- 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 new file mode 100644 index 000000000..8ae69a126 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa016.a @@ -0,0 +1,462 @@ +-- 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 new file mode 100644 index 000000000..17d0922cc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa017.a @@ -0,0 +1,400 @@ +-- 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 new file mode 100644 index 000000000..53b16fea4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa018.a @@ -0,0 +1,277 @@ +-- 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 new file mode 100644 index 000000000..04c257e97 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaa019.a @@ -0,0 +1,138 @@ +-- 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 new file mode 100644 index 000000000..483acd16c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxab001.a @@ -0,0 +1,272 @@ +-- 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 new file mode 100644 index 000000000..a77d561f5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxac001.a @@ -0,0 +1,292 @@ +-- 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 new file mode 100644 index 000000000..e4b303c4b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxac002.a @@ -0,0 +1,426 @@ +-- 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 new file mode 100644 index 000000000..cc1e044d0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxac003.a @@ -0,0 +1,376 @@ +-- 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 new file mode 100644 index 000000000..9cc88b93c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxac004.a @@ -0,0 +1,310 @@ +-- 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 new file mode 100644 index 000000000..34a971f7a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxac005.a @@ -0,0 +1,343 @@ +-- 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. +-- +--! +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; + function Stream_Io_File (File : File_Type) return Stream_Io.File_Type; + + 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; + + 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; + + function Stream_Io_File (File : File_Type) return Stream_Io.File_Type is + begin + return File.File; + end Stream_Io_File; + + 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; + + 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 + + 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 + (Stream_Io.Size (Csio.Stream_Io_File (F)))); + begin + Csio.Reset (F, Stream_Io.In_File); + Csio.Read (F, S, Last); + end; + + Csio.Delete (F); + end; + + 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 new file mode 100644 index 000000000..cda8776a5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaca01.a @@ -0,0 +1,291 @@ +-- 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 new file mode 100644 index 000000000..5106dd399 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaca02.a @@ -0,0 +1,360 @@ +-- 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 new file mode 100644 index 000000000..ac4a905e8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxacb01.a @@ -0,0 +1,264 @@ +-- 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 new file mode 100644 index 000000000..a0ade9ebe --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxacb02.a @@ -0,0 +1,421 @@ +-- 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 new file mode 100644 index 000000000..3ab88f40e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxacc01.a @@ -0,0 +1,299 @@ +-- 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 new file mode 100644 index 000000000..ae3497abd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxa/cxaf001.a @@ -0,0 +1,199 @@ +-- 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 new file mode 100644 index 000000000..73f9209cd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb2001.a @@ -0,0 +1,633 @@ +-- 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 new file mode 100644 index 000000000..945722295 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb2002.a @@ -0,0 +1,259 @@ +-- 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 new file mode 100644 index 000000000..ec3998ad8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb2003.a @@ -0,0 +1,255 @@ +-- 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 new file mode 100644 index 000000000..4d79b24e1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3001.a @@ -0,0 +1,179 @@ +-- 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 new file mode 100644 index 000000000..b543d467c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3002.a @@ -0,0 +1,158 @@ +-- 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 new file mode 100644 index 000000000..c39583748 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3003.a @@ -0,0 +1,167 @@ +-- 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 new file mode 100644 index 000000000..1e96e4a57 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb30040.c @@ -0,0 +1,172 @@ +/* +-- 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 new file mode 100644 index 000000000..73b874e1f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb30041.am @@ -0,0 +1,377 @@ +-- 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 new file mode 100644 index 000000000..30b940535 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3005.a @@ -0,0 +1,396 @@ +-- 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 new file mode 100644 index 000000000..c4df00868 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb30060.c @@ -0,0 +1,174 @@ +/* +-- 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 + +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/cxb3007.a b/gcc/testsuite/ada/acats/tests/cxb/cxb3007.a new file mode 100644 index 000000000..3837e0bae --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3007.a @@ -0,0 +1,408 @@ +-- 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 new file mode 100644 index 000000000..9df19d814 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3008.a @@ -0,0 +1,226 @@ +-- 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 and +-- libraries can be called from an Ada program. +-- +-- TEST DESCRIPTION: +-- This test checks that C language functions from the and +-- 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 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 strlen function as a completion to the + -- String_Length function specification. + + pragma Import (C, String_Length, "strlen"); + + -- Use the 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 new file mode 100644 index 000000000..3ea5a6204 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3009.a @@ -0,0 +1,305 @@ +-- 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 new file mode 100644 index 000000000..25305b22f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3010.a @@ -0,0 +1,320 @@ +-- 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 new file mode 100644 index 000000000..6930407ec --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3011.a @@ -0,0 +1,282 @@ +-- 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 new file mode 100644 index 000000000..3771f6e68 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3012.a @@ -0,0 +1,392 @@ +-- 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 new file mode 100644 index 000000000..57662a323 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb30130.c @@ -0,0 +1,86 @@ +/* +-- 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 new file mode 100644 index 000000000..6cbbdd131 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb30131.c @@ -0,0 +1,104 @@ +/* +-- 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 +#include + +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 new file mode 100644 index 000000000..4cff400b8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb30132.am @@ -0,0 +1,205 @@ +-- 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 new file mode 100644 index 000000000..a9b386ffc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3014.a @@ -0,0 +1,254 @@ +-- 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 new file mode 100644 index 000000000..24ec826fa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3015.a @@ -0,0 +1,520 @@ +-- 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 new file mode 100644 index 000000000..362a062ad --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb3016.a @@ -0,0 +1,516 @@ +-- 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 new file mode 100644 index 000000000..0c9ab1a62 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb4001.a @@ -0,0 +1,230 @@ +-- 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 new file mode 100644 index 000000000..e3934a5ef --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb4002.a @@ -0,0 +1,308 @@ +-- 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 new file mode 100644 index 000000000..609dabc50 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb4003.a @@ -0,0 +1,310 @@ +-- 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 new file mode 100644 index 000000000..0046c5e7c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb4004.a @@ -0,0 +1,443 @@ +-- 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 new file mode 100644 index 000000000..01f1ded1d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb4005.a @@ -0,0 +1,332 @@ +-- 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 new file mode 100644 index 000000000..6e491eebf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb4006.a @@ -0,0 +1,322 @@ +-- 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 new file mode 100644 index 000000000..c4e064176 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb4007.a @@ -0,0 +1,271 @@ +-- 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 new file mode 100644 index 000000000..5ab8e6b03 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb4008.a @@ -0,0 +1,248 @@ +-- 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 new file mode 100644 index 000000000..a681c5f13 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb5001.a @@ -0,0 +1,110 @@ +-- 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 new file mode 100644 index 000000000..3da7cc9b1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb5002.a @@ -0,0 +1,334 @@ +-- 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 new file mode 100644 index 000000000..1c2b1c537 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxb/cxb5003.a @@ -0,0 +1,295 @@ +-- 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 new file mode 100644 index 000000000..be7e50692 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxf/cxf1001.a @@ -0,0 +1,261 @@ +-- 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 new file mode 100644 index 000000000..96d0a0a17 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxf/cxf2001.a @@ -0,0 +1,755 @@ +-- 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. +-- +--! + +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_10_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 new file mode 100644 index 000000000..984daa97b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxf/cxf2002.a @@ -0,0 +1,352 @@ +-- 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 new file mode 100644 index 000000000..133dc48e6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxf/cxf2003.a @@ -0,0 +1,363 @@ +-- 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 new file mode 100644 index 000000000..9651384ce --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxf/cxf2004.a @@ -0,0 +1,513 @@ +-- 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 new file mode 100644 index 000000000..71cd5bb31 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxf/cxf2005.a @@ -0,0 +1,293 @@ +-- 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 new file mode 100644 index 000000000..002c59d6c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxf/cxf2a01.a @@ -0,0 +1,448 @@ +-- 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 new file mode 100644 index 000000000..e9977b0f5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxf/cxf2a02.a @@ -0,0 +1,354 @@ +-- 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 new file mode 100644 index 000000000..1b9abca15 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxf/cxf3001.a @@ -0,0 +1,192 @@ +-- 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 new file mode 100644 index 000000000..8444244ef --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxf/cxf3002.a @@ -0,0 +1,231 @@ +-- 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 new file mode 100644 index 000000000..7cfce618e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxf/cxf3003.a @@ -0,0 +1,292 @@ +-- 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 new file mode 100644 index 000000000..146047bc8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxf/cxf3004.a @@ -0,0 +1,257 @@ +-- 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 new file mode 100644 index 000000000..202a6996e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxf/cxf3a01.a @@ -0,0 +1,167 @@ +-- 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 new file mode 100644 index 000000000..4231b56aa --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxf/cxf3a02.a @@ -0,0 +1,267 @@ +-- 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 new file mode 100644 index 000000000..867096014 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxf/cxf3a03.a @@ -0,0 +1,429 @@ +-- 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 new file mode 100644 index 000000000..9eee39bb6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxf/cxf3a04.a @@ -0,0 +1,293 @@ +-- 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 new file mode 100644 index 000000000..3fb39332a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxf/cxf3a05.a @@ -0,0 +1,266 @@ +-- 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 new file mode 100644 index 000000000..7b769ba96 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxf/cxf3a06.a @@ -0,0 +1,302 @@ +-- 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 new file mode 100644 index 000000000..7cb2c360c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxf/cxf3a07.a @@ -0,0 +1,337 @@ +-- 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 new file mode 100644 index 000000000..871ab5600 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxf/cxf3a08.a @@ -0,0 +1,289 @@ +-- 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 new file mode 100644 index 000000000..01a0f061e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg1001.a @@ -0,0 +1,276 @@ +-- 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 new file mode 100644 index 000000000..39f5f00db --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg1002.a @@ -0,0 +1,198 @@ +-- 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 new file mode 100644 index 000000000..c3885136b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg1003.a @@ -0,0 +1,478 @@ +-- 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 new file mode 100644 index 000000000..f026eae70 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg1004.a @@ -0,0 +1,360 @@ +-- 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 new file mode 100644 index 000000000..6faad4e13 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg1005.a @@ -0,0 +1,393 @@ +-- 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 new file mode 100644 index 000000000..0d7afa460 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2001.a @@ -0,0 +1,322 @@ +-- 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 new file mode 100644 index 000000000..6a1f322e8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2002.a @@ -0,0 +1,468 @@ +-- 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 new file mode 100644 index 000000000..d1a225a50 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2003.a @@ -0,0 +1,701 @@ +-- 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 new file mode 100644 index 000000000..2df296d3d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2004.a @@ -0,0 +1,499 @@ +-- 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 new file mode 100644 index 000000000..4054b83d8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2005.a @@ -0,0 +1,204 @@ +-- 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 new file mode 100644 index 000000000..da15dc3be --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2006.a @@ -0,0 +1,281 @@ +-- 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 new file mode 100644 index 000000000..ba07df29d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2007.a @@ -0,0 +1,291 @@ +-- 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 new file mode 100644 index 000000000..58cf367f6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2008.a @@ -0,0 +1,948 @@ +-- 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 new file mode 100644 index 000000000..0b11ca538 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2009.a @@ -0,0 +1,421 @@ +-- 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 new file mode 100644 index 000000000..4140a4875 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2010.a @@ -0,0 +1,892 @@ +-- 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 new file mode 100644 index 000000000..2c018b132 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2011.a @@ -0,0 +1,490 @@ +-- 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 new file mode 100644 index 000000000..6a665d0e0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2012.a @@ -0,0 +1,438 @@ +-- 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 new file mode 100644 index 000000000..94f180b80 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2013.a @@ -0,0 +1,367 @@ +-- 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 new file mode 100644 index 000000000..48499a255 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2014.a @@ -0,0 +1,399 @@ +-- 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 new file mode 100644 index 000000000..50fda5e1f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2015.a @@ -0,0 +1,686 @@ +-- 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 new file mode 100644 index 000000000..832b11822 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2016.a @@ -0,0 +1,482 @@ +-- 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 new file mode 100644 index 000000000..50add975f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2017.a @@ -0,0 +1,296 @@ +-- 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 new file mode 100644 index 000000000..be4f1a82f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2018.a @@ -0,0 +1,355 @@ +-- 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 new file mode 100644 index 000000000..0a4dddcc9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2019.a @@ -0,0 +1,338 @@ +-- 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 new file mode 100644 index 000000000..1aed4ca57 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2020.a @@ -0,0 +1,351 @@ +-- 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 new file mode 100644 index 000000000..db49fc845 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2021.a @@ -0,0 +1,386 @@ +-- 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 new file mode 100644 index 000000000..f9e4d1cae --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2022.a @@ -0,0 +1,309 @@ +-- 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 new file mode 100644 index 000000000..0cdd5574e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2023.a @@ -0,0 +1,351 @@ +-- 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 new file mode 100644 index 000000000..55648283e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxg/cxg2024.a @@ -0,0 +1,191 @@ +-- 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/cxh1001.a b/gcc/testsuite/ada/acats/tests/cxh/cxh1001.a new file mode 100644 index 000000000..12379a1a5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxh/cxh1001.a @@ -0,0 +1,349 @@ +-- CXH1001.A +-- +-- Grant of Unlimited Rights +-- +-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, +-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained +-- unlimited rights in the software and documentation contained herein. +-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making +-- this public release, the Government intends to confer upon all +-- recipients unlimited rights equal to those held by the Government. +-- These rights include rights to use, duplicate, release or disclose the +-- released technical data and computer software in whole or in part, in +-- any manner and for any purpose whatsoever, and to have or permit others +-- to do so. +-- +-- DISCLAIMER +-- +-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR +-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED +-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE +-- SOFTWARE, 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 Normalize_Scalars. +-- Check that this configuration pragma causes uninitialized scalar +-- objects to be set to a predictable value. Check that multiple +-- compilation units are affected. Check for uninitialized scalar +-- objects that are subcomponents of composite objects, unassigned +-- out parameters, objects that have been allocated without an initial +-- value, and objects that are stand alone. +-- +-- TEST DESCRIPTION +-- The test requires that the configuration pragma Normalize_Scalars +-- be processed. It then defines a few scalar types (some enumeration, +-- some integer) in a few packages. The scalar types are designed such +-- that the representation will easily allow for an out of range value. +-- Unchecked_Conversion and the 'Valid attribute are both used to verify +-- that the default values of the various kinds of objects are indeed +-- invalid for the type. +-- +-- Note that this test relies on having uninitialized objects, compilers +-- may generate several warnings to this effect. +-- +-- SPECIAL REQUIREMENTS +-- The implementation must process configuration pragmas which +-- are not part of any Compilation Unit; the method employed +-- is implementation defined. +-- +-- 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 +-- 04 NOV 96 SAIC Added cases, upgraded commentary +-- +--! + +---------------------------- CONFIGURATION PRAGMAS ----------------------- + +pragma Normalize_Scalars; -- OK + -- configuration pragma + +------------------------ END OF CONFIGURATION PRAGMAS -------------------- + + +----------------------------------------------------------------- CXH1001_0 + +with Impdef.Annex_H; +with Unchecked_Conversion; +package CXH1001_0 is + + package Imp_H renames Impdef.Annex_H; + use type Imp_H.Small_Number; + use type Imp_H.Scalar_To_Normalize; + + Global_Object : Imp_H.Scalar_To_Normalize; + -- if the pragma is in effect, this should come up with the predictable + -- value + + Global_Number : Imp_H.Small_Number; + -- if the pragma is in effect, this should come up with the predictable + -- value + + procedure Package_Check; + + type Num is range 0..2**Imp_H.Scalar_To_Normalize'Size-1; + for Num'Size use Imp_H.Scalar_To_Normalize'Size; + + function STN_2_Num is + new Unchecked_Conversion( Imp_H.Scalar_To_Normalize, Num ); + + Small_Last : constant Integer := Integer(Imp_H.Small_Number'Last); + +end CXH1001_0; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +package body CXH1001_0 is + + procedure Heap_Check( A_Value : access Imp_H.Scalar_To_Normalize; + A_Number : access Imp_H.Small_Number ) is + Value : Num; + Number : Integer; + begin + + if A_Value.all'Valid then + Value := STN_2_Num ( A_Value.all ); + if Imp_H.Default_For_Scalar_To_Normalize_Is_In_Range then + if Imp_H.Scalar_To_Normalize'Val(Value) + /= Imp_H.Default_For_Scalar_To_Normalize then + Report.Failed("Implicit initial value for local variable is not " + & "the predicted value"); + end if; + else + if Value in 0 .. + Imp_H.Scalar_To_Normalize'Pos(Imp_H.Scalar_To_Normalize'Last) then + Report.Failed("Implicit initial value for local variable is a " + & "value of the type"); + end if; + end if; + end if; + + if A_Number.all'Valid then + Number := Integer( A_Number.all ); + if Imp_H.Default_For_Small_Number_Is_In_Range then + if Global_Number /= Imp_H.Default_For_Small_Number then + Report.Failed("Implicit initial value for number is not " + & "the predicted value"); + end if; + else + if Integer( Global_Number ) in 0 .. Report.Ident_Int(Small_Last) then + Report.Failed("Implicit initial value for number is a " + & "value of the type"); + end if; + end if; + end if; + + end Heap_Check; + + procedure Package_Check is + Value : Num; + Number : Integer; + begin + + if Global_Object'Valid then + Value := STN_2_Num ( Global_Object ); + if Imp_H.Default_For_Scalar_To_Normalize_Is_In_Range then + if Imp_H.Scalar_To_Normalize'Val(Value) + /= Imp_H.Default_For_Scalar_To_Normalize then + Report.Failed("Implicit initial value for local variable is not " + & "the predicted value"); + end if; + else + if Value in 0 .. + Imp_H.Scalar_To_Normalize'Pos(Imp_H.Scalar_To_Normalize'Last) then + Report.Failed("Implicit initial value for local variable is a " + & "value of the type"); + end if; + end if; + end if; + + if Global_Number'Valid then + Number := Integer( Global_Number ); + if Imp_H.Default_For_Small_Number_Is_In_Range then + if Global_Number /= Imp_H.Default_For_Small_Number then + Report.Failed("Implicit initial value for number is not " + & "the predicted value"); + end if; + else + if Integer( Global_Number ) in 0 .. Report.Ident_Int(Small_Last) then + Report.Failed("Implicit initial value for number is a " + & "value of the type"); + end if; + end if; + end if; + + Heap_Check( new Imp_H.Scalar_To_Normalize, new Imp_H.Small_Number ); + + end Package_Check; + +end CXH1001_0; + +----------------------------------------------------------------- CXH1001_1 + +with Unchecked_Conversion; +package CXH1001_0.CXH1001_1 is + + -- kill as many birds as possible with a single stone: + -- embed a protected object in the body of a child package, + -- checks the multiple compilation unit case, + -- and part of the subcomponent case. + + protected Thingy is + procedure Check_Embedded_Values; + private + Hidden_Object : Imp_H.Scalar_To_Normalize; -- not initialized + Hidden_Number : Imp_H.Small_Number; -- not initialized + end Thingy; + +end CXH1001_0.CXH1001_1; + +-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + +with Report; +package body CXH1001_0.CXH1001_1 is + + Childs_Object : Imp_H.Scalar_To_Normalize; -- not initialized + + protected body Thingy is + + procedure Check_Embedded_Values is + begin + + if Imp_H.Default_For_Scalar_To_Normalize_Is_In_Range then + if Childs_Object /= Imp_H.Default_For_Scalar_To_Normalize then + Report.Failed("Implicit initial value for child object is not " + & "the predicted value"); + end if; + elsif Childs_Object'Valid and then STN_2_Num( Childs_Object ) in 0 .. + Imp_H.Scalar_To_Normalize'Pos(Imp_H.Scalar_To_Normalize'Last) then + Report.Failed("Implicit initial value for child object is a " + & "value of the type"); + end if; + + if Imp_H.Default_For_Scalar_To_Normalize_Is_In_Range then + if Hidden_Object /= Imp_H.Default_For_Scalar_To_Normalize then + Report.Failed("Implicit initial value for protected package object " + & "is not the predicted value"); + end if; + elsif Hidden_Object'Valid and then STN_2_Num( Hidden_Object ) in 0 .. + Imp_H.Scalar_To_Normalize'Pos(Imp_H.Scalar_To_Normalize'Last) then + Report.Failed("Implicit initial value for protected component " + & "is a value of the type"); + end if; + + if Imp_H.Default_For_Small_Number_Is_In_Range then + if Hidden_Number /= Imp_H.Default_For_Small_Number then + Report.Failed("Implicit initial value for protected number " + & "is not the predicted value"); + end if; + elsif Hidden_Number'Valid and then Hidden_Number in + 0 .. Imp_H.Small_Number(Report.Ident_Int(Small_Last)) then + Report.Failed("Implicit initial value for protected number " + & "is a value of the type"); + end if; + + end Check_Embedded_Values; + + end Thingy; + +end CXH1001_0.CXH1001_1; + +------------------------------------------------------------------- CXH1001 + +with Impdef.Annex_H; +with Report; +with CXH1001_0.CXH1001_1; +procedure CXH1001 is + + package Imp_H renames Impdef.Annex_H; + use type CXH1001_0.Num; + + My_Object : Imp_H.Scalar_To_Normalize; -- not initialized + + Value : CXH1001_0.Num := CXH1001_0.STN_2_Num ( My_Object ); + -- My_Object is not initialized + + Parameter_Value : Imp_H.Scalar_To_Normalize + := Imp_H.Scalar_To_Normalize'Last; + + type Structure is record -- not initialized + Std_Int : Integer; + Scalar : Imp_H.Scalar_To_Normalize; + Num : CXH1001_0.Num; + end record; + + S : Structure; -- not initialized + + procedure Bad_Code( Unassigned : out Imp_H.Scalar_To_Normalize ) is + -- returns uninitialized OUT parameter + begin + + if Report.Ident_Int( 0 ) = 1 then + Report.Failed( "Nothing is something" ); + Unassigned := Imp_H.Scalar_To_Normalize'First; + end if; + + end Bad_Code; + + procedure Check( V : CXH1001_0.Num; Message : String ) is + begin + + + if Imp_H.Default_For_Scalar_To_Normalize_Is_In_Range then + if V /= Imp_H.Scalar_To_Normalize'Pos( + Imp_H.Default_For_Scalar_To_Normalize) then + Report.Failed(Message & ": Implicit initial value for object " + & "is not the predicted value"); + end if; + elsif V'Valid and then V in + 0 .. Imp_H.Scalar_To_Normalize'Pos(Imp_H.Scalar_To_Normalize'Last) then + Report.Failed(Message & ": Implicit initial value for object " + & "is a value of the type"); + end if; + + end Check; + +begin -- Main test procedure. + + Report.Test ("CXH1001", "Check that the configuration pragma " & + "Normalize_Scalars causes uninitialized scalar " & + "objects to be set to a predictable value. " & + "Check that multiple compilation units are " & + "affected. Check for uninitialized scalar " & + "objects that are subcomponents of composite " & + "objects, unassigned out parameters, have been " & + "allocated without an initial value, and are " & + "stand alone." ); + + CXH1001_0.Package_Check; + + if My_Object'Valid then + Value := CXH1001_0.STN_2_Num ( My_Object ); -- My_Object not initialized + end if; + -- otherwise, we just leave Value uninitialized + + Check( Value, "main procedure variable" ); + + Bad_Code( Parameter_Value ); + + if Parameter_Value'Valid then + Check( CXH1001_0.STN_2_Num ( Parameter_Value ), "Out parameter return" ); + end if; + + if S.Scalar'Valid then + Check( CXH1001_0.STN_2_Num ( S.Scalar ), "Record component" ); + end if; + + CXH1001_0.CXH1001_1.Thingy.Check_Embedded_Values; + + Report.Result; + +end CXH1001; diff --git a/gcc/testsuite/ada/acats/tests/cxh/cxh3001.a b/gcc/testsuite/ada/acats/tests/cxh/cxh3001.a new file mode 100644 index 000000000..4ed41b4d0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxh/cxh3001.a @@ -0,0 +1,243 @@ +-- 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 new file mode 100644 index 000000000..5e9f7b9cc --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxh/cxh3002.a @@ -0,0 +1,343 @@ +-- 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 new file mode 100644 index 000000000..1b1399c59 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxh/cxh30030.a @@ -0,0 +1,54 @@ +-- 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 new file mode 100644 index 000000000..91bf3e8a5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cxh/cxh30031.am @@ -0,0 +1,215 @@ +-- 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 new file mode 100644 index 000000000..394575fed --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cz/cz1101a.ada @@ -0,0 +1,111 @@ +-- 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 new file mode 100644 index 000000000..0255bb440 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cz/cz1102a.ada @@ -0,0 +1,75 @@ +-- 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 new file mode 100644 index 000000000..87756c88f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cz/cz1103a.ada @@ -0,0 +1,232 @@ +-- 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 new file mode 100644 index 000000000..a2ec008fb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/d/d4a002a.ada @@ -0,0 +1,54 @@ +-- 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 new file mode 100644 index 000000000..6278254b3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/d/d4a002b.ada @@ -0,0 +1,56 @@ +-- 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 new file mode 100644 index 000000000..7c744d756 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/d/d4a004a.ada @@ -0,0 +1,59 @@ +-- 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 new file mode 100644 index 000000000..f2e2b75cd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/d/d4a004b.ada @@ -0,0 +1,72 @@ +-- 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 new file mode 100644 index 000000000..d7c7869e4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/e/e28002b.ada @@ -0,0 +1,111 @@ +-- 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 new file mode 100644 index 000000000..a6632d65f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/e/e28005d.ada @@ -0,0 +1,55 @@ +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 new file mode 100644 index 000000000..e2a7a95a0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/e/e52103y.ada @@ -0,0 +1,132 @@ +-- 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 new file mode 100644 index 000000000..24705ba5f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/e/eb4011a.ada @@ -0,0 +1,79 @@ +-- 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 new file mode 100644 index 000000000..7166c0b08 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/e/eb4012a.ada @@ -0,0 +1,59 @@ +-- 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 new file mode 100644 index 000000000..d520bd054 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/e/eb4014a.ada @@ -0,0 +1,87 @@ +-- 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 new file mode 100644 index 000000000..a31887d96 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/e/ee3203a.ada @@ -0,0 +1,168 @@ +-- 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 new file mode 100644 index 000000000..2482b1940 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/e/ee3204a.ada @@ -0,0 +1,128 @@ +-- 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 new file mode 100644 index 000000000..ee6660b1d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/e/ee3402b.ada @@ -0,0 +1,118 @@ +-- 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 new file mode 100644 index 000000000..8460c4665 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/e/ee3409f.ada @@ -0,0 +1,103 @@ +-- 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 new file mode 100644 index 000000000..b5c10ab49 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/e/ee3412c.ada @@ -0,0 +1,144 @@ +-- 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/gcc/template.ada b/gcc/testsuite/ada/acats/tests/gcc/template.ada new file mode 100644 index 000000000..d1a0945ee --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/gcc/template.ada @@ -0,0 +1,16 @@ +with Report; use Report; + +procedure Template is +begin + -- Test header + Test ("TEMPLATE", "Template test for GNU Ada test suite"); + + begin + -- Body of test + -- Call procedure Failed when detecting a failure + Failed ("Pretend this test failed"); + end; + + -- Display result + Result; +end Template; diff --git a/gcc/testsuite/ada/acats/tests/l/la140010.a b/gcc/testsuite/ada/acats/tests/l/la140010.a new file mode 100644 index 000000000..58ba66195 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140010.a @@ -0,0 +1,51 @@ +-- 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 new file mode 100644 index 000000000..7fd722def --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140011.am @@ -0,0 +1,104 @@ +-- 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 new file mode 100644 index 000000000..1dc8a7c92 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140012.a @@ -0,0 +1,55 @@ +-- 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 new file mode 100644 index 000000000..6b49ca2d1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140020.a @@ -0,0 +1,60 @@ +-- 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 new file mode 100644 index 000000000..963e17137 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140021.am @@ -0,0 +1,98 @@ +-- 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 new file mode 100644 index 000000000..75a4c4483 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140022.a @@ -0,0 +1,66 @@ +-- 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 new file mode 100644 index 000000000..82d97e787 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140030.a @@ -0,0 +1,57 @@ +-- 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 new file mode 100644 index 000000000..250162b28 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140031.a @@ -0,0 +1,66 @@ +-- 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 new file mode 100644 index 000000000..89984be12 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140032.am @@ -0,0 +1,101 @@ +-- 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 new file mode 100644 index 000000000..9d7f13366 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140033.a @@ -0,0 +1,56 @@ +-- 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 new file mode 100644 index 000000000..eef6d9874 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140040.a @@ -0,0 +1,52 @@ +-- 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 new file mode 100644 index 000000000..00470b2e2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140041.am @@ -0,0 +1,108 @@ +-- 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 new file mode 100644 index 000000000..bb4ba6c09 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140042.a @@ -0,0 +1,53 @@ +-- 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 new file mode 100644 index 000000000..542c1ffdd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140050.a @@ -0,0 +1,60 @@ +-- 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 new file mode 100644 index 000000000..6af550a3a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140051.a @@ -0,0 +1,56 @@ +-- 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 new file mode 100644 index 000000000..8e6c59eb8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140052.am @@ -0,0 +1,110 @@ +-- 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 new file mode 100644 index 000000000..406b3abb0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140053.a @@ -0,0 +1,60 @@ +-- 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 new file mode 100644 index 000000000..4f54da1e6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140060.a @@ -0,0 +1,54 @@ +-- 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 new file mode 100644 index 000000000..40ff151cb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140061.a @@ -0,0 +1,66 @@ +-- 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 new file mode 100644 index 000000000..9cfb8ddf2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140062.am @@ -0,0 +1,135 @@ +-- 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 new file mode 100644 index 000000000..e4e6457d0 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140063.a @@ -0,0 +1,70 @@ +-- 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 new file mode 100644 index 000000000..e3c864ac4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140070.a @@ -0,0 +1,62 @@ +-- 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 new file mode 100644 index 000000000..e895b8744 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140071.a @@ -0,0 +1,72 @@ +-- 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 new file mode 100644 index 000000000..86ef201fe --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140072.am @@ -0,0 +1,102 @@ +-- 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 new file mode 100644 index 000000000..01e071519 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140073.a @@ -0,0 +1,63 @@ +-- 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 new file mode 100644 index 000000000..506c18251 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140080.a @@ -0,0 +1,52 @@ +-- 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 new file mode 100644 index 000000000..b800da799 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140081.a @@ -0,0 +1,63 @@ +-- 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 new file mode 100644 index 000000000..fc34a466c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140082.am @@ -0,0 +1,106 @@ +-- 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 new file mode 100644 index 000000000..cad1cf311 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140083.a @@ -0,0 +1,61 @@ +-- 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 new file mode 100644 index 000000000..d2e02c714 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140090.a @@ -0,0 +1,60 @@ +-- 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 new file mode 100644 index 000000000..550b908fb --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140091.a @@ -0,0 +1,60 @@ +-- 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 new file mode 100644 index 000000000..a4f248f95 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140092.am @@ -0,0 +1,110 @@ +-- 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 new file mode 100644 index 000000000..375570675 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140093.a @@ -0,0 +1,59 @@ +-- 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 new file mode 100644 index 000000000..dfa786966 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140100.a @@ -0,0 +1,56 @@ +-- 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 new file mode 100644 index 000000000..332f5ff20 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140101.a @@ -0,0 +1,89 @@ +-- 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 new file mode 100644 index 000000000..7feb2efea --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140102.am @@ -0,0 +1,104 @@ +-- 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 new file mode 100644 index 000000000..a16d7debf --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140103.a @@ -0,0 +1,58 @@ +-- 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 new file mode 100644 index 000000000..3f69c92a9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140110.a @@ -0,0 +1,64 @@ +-- 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 new file mode 100644 index 000000000..c3a1cf1a1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140111.a @@ -0,0 +1,62 @@ +-- 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 new file mode 100644 index 000000000..36dc8ff12 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140112.am @@ -0,0 +1,103 @@ +-- 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 new file mode 100644 index 000000000..8dd9683e3 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140113.a @@ -0,0 +1,59 @@ +-- 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 new file mode 100644 index 000000000..d21525ed4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140120.a @@ -0,0 +1,63 @@ +-- 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 new file mode 100644 index 000000000..e4ea3ed9a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140121.a @@ -0,0 +1,64 @@ +-- 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 new file mode 100644 index 000000000..06cacb3e6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140122.am @@ -0,0 +1,102 @@ +-- 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 new file mode 100644 index 000000000..cacbf64e4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140123.a @@ -0,0 +1,59 @@ +-- 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 new file mode 100644 index 000000000..a65ce8001 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140130.a @@ -0,0 +1,57 @@ +-- 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 new file mode 100644 index 000000000..fe03f6705 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140131.a @@ -0,0 +1,58 @@ +-- 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 new file mode 100644 index 000000000..fe39257f2 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140132.am @@ -0,0 +1,102 @@ +-- 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 new file mode 100644 index 000000000..4d1451e4e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140133.a @@ -0,0 +1,58 @@ +-- 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 new file mode 100644 index 000000000..21168913c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140140.a @@ -0,0 +1,55 @@ +-- 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 new file mode 100644 index 000000000..d0406e6e5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140141.a @@ -0,0 +1,57 @@ +-- 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 new file mode 100644 index 000000000..39b70dda1 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140142.am @@ -0,0 +1,102 @@ +-- 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 new file mode 100644 index 000000000..2c21b1bef --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140143.a @@ -0,0 +1,64 @@ +-- 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 new file mode 100644 index 000000000..77a5a21a8 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140150.a @@ -0,0 +1,56 @@ +-- 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 new file mode 100644 index 000000000..6cd0d1a64 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140151.a @@ -0,0 +1,65 @@ +-- 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 new file mode 100644 index 000000000..bc9847050 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140152.am @@ -0,0 +1,101 @@ +-- 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 new file mode 100644 index 000000000..812644595 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140153.a @@ -0,0 +1,61 @@ +-- 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 new file mode 100644 index 000000000..38c396d96 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140160.a @@ -0,0 +1,54 @@ +-- 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 new file mode 100644 index 000000000..4be9f1dfd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140161.a @@ -0,0 +1,63 @@ +-- 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 new file mode 100644 index 000000000..fd985c295 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140162.am @@ -0,0 +1,196 @@ +-- 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 new file mode 100644 index 000000000..d91923a6c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140163.a @@ -0,0 +1,67 @@ +-- 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 new file mode 100644 index 000000000..0c041d00a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140170.a @@ -0,0 +1,64 @@ +-- 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 new file mode 100644 index 000000000..d7f37663c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140171.a @@ -0,0 +1,69 @@ +-- 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 new file mode 100644 index 000000000..67c970e5a --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140172.am @@ -0,0 +1,121 @@ +-- 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 new file mode 100644 index 000000000..73f382e72 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140173.a @@ -0,0 +1,75 @@ +-- 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 new file mode 100644 index 000000000..185ca21f4 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140180.a @@ -0,0 +1,65 @@ +-- 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 new file mode 100644 index 000000000..3d9847a98 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140181.a @@ -0,0 +1,54 @@ +-- 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 new file mode 100644 index 000000000..c27bb541f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140182.am @@ -0,0 +1,118 @@ +-- 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 new file mode 100644 index 000000000..f50ae15ba --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140183.a @@ -0,0 +1,60 @@ +-- 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 new file mode 100644 index 000000000..0c4c3a9d6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140190.a @@ -0,0 +1,61 @@ +-- 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 new file mode 100644 index 000000000..8b7af2e7c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140191.a @@ -0,0 +1,74 @@ +-- 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 new file mode 100644 index 000000000..c5f32905d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140192.am @@ -0,0 +1,107 @@ +-- 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 new file mode 100644 index 000000000..717cc633b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140193.a @@ -0,0 +1,64 @@ +-- 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 new file mode 100644 index 000000000..9adf75e67 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140200.a @@ -0,0 +1,76 @@ +-- 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 new file mode 100644 index 000000000..668225532 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140201.a @@ -0,0 +1,71 @@ +-- 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 new file mode 100644 index 000000000..1a4ed7676 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140202.am @@ -0,0 +1,144 @@ +-- 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 new file mode 100644 index 000000000..f2965b407 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140203.a @@ -0,0 +1,71 @@ +-- 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 new file mode 100644 index 000000000..ab3ad5f77 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140210.a @@ -0,0 +1,69 @@ +-- 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 new file mode 100644 index 000000000..f6b17576d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140211.am @@ -0,0 +1,134 @@ +-- 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 new file mode 100644 index 000000000..0c689b999 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140212.a @@ -0,0 +1,74 @@ +-- 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 new file mode 100644 index 000000000..c5e4c6575 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140220.a @@ -0,0 +1,64 @@ +-- 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 new file mode 100644 index 000000000..84003a62f --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140221.am @@ -0,0 +1,128 @@ +-- 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 new file mode 100644 index 000000000..424236b3e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140222.a @@ -0,0 +1,69 @@ +-- 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 new file mode 100644 index 000000000..e5541006e --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140240.a @@ -0,0 +1,61 @@ +-- 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 new file mode 100644 index 000000000..dde3b3db5 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140241.a @@ -0,0 +1,55 @@ +-- 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 new file mode 100644 index 000000000..a156465a9 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140242.am @@ -0,0 +1,104 @@ +-- 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 new file mode 100644 index 000000000..98b03438b --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140243.a @@ -0,0 +1,61 @@ +-- 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 new file mode 100644 index 000000000..44477df4d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140250.a @@ -0,0 +1,56 @@ +-- 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 new file mode 100644 index 000000000..7f7a4791d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140251.am @@ -0,0 +1,141 @@ +-- 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 new file mode 100644 index 000000000..2fce76cea --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140252.a @@ -0,0 +1,59 @@ +-- 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 new file mode 100644 index 000000000..fae173667 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140260.a @@ -0,0 +1,98 @@ +-- 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 new file mode 100644 index 000000000..73cd334ed --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140261.a @@ -0,0 +1,52 @@ +-- 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 new file mode 100644 index 000000000..115094717 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140262.am @@ -0,0 +1,140 @@ +-- 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 new file mode 100644 index 000000000..c0224894d --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140263.a @@ -0,0 +1,57 @@ +-- 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 new file mode 100644 index 000000000..dab574cd6 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140270.a @@ -0,0 +1,56 @@ +-- 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 new file mode 100644 index 000000000..703b1b8ae --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140271.a @@ -0,0 +1,93 @@ +-- 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 new file mode 100644 index 000000000..a8cd1c958 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140272.am @@ -0,0 +1,102 @@ +-- 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 new file mode 100644 index 000000000..0e535f10c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/l/la140273.a @@ -0,0 +1,58 @@ +-- 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; -- cgit v1.2.3